Добавить условие в макрос подстановки значений

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавить условие в макрос подстановки значений (Макросы/Sub)

micholap_denis

Дата: Среда, 10.08.2022, 08:52 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

Репутация: 0 ±

Замечаний: 60% ±

Excel 2013

День добрый
а подправьте пожалуйста макрос так что бы он срабатывал только на строки отмеченные в столбце отметка "1"
[vba]

Код

Sub www()
    Dim oTbl As ListObject, cell As Range, trg As Range, s$
    Application.ScreenUpdating = False
    For Each trg In Sheets("Лист1").ListObjects("Таблица1").DataBodyRange.Columns(1).Cells
        For Each oTbl In Sheets("Лист2").ListObjects
            For Each cell In oTbl.DataBodyRange.Columns(1).Cells
                If trg.Value Like "*" & cell.Value & "*" Then
                    s = oTbl.HeaderRowRange.Cells(1)
                    Select Case s
                    Case "Сельхоз", "Производство"
                        trg.Offset(, 1) = s
                    Case "Дерево", "Фрукт", "Инструмент"
                        trg.Offset(, 2) = s
                    End Select
                End If
            Next cell
        Next oTbl
    Next trg
    Application.ScreenUpdating = True
End Sub

[/vba]