Советы по макросам - вставка строк в новый лист, если в определенных ячейках указано "НЕТ"

Question

Я хотел бы получить несколько советов по использованию VBA и макросов.

Я хотел бы связать рабочие листы (рабочие листы с 1 по 6) с основным листом (рабочий лист 7).

Если строка содержит "НЕТ" в столбце I (на листах с 1 по 6), может ли код скопировать и вставить эту строку в лист 7?

Тогда, если строка (в таблицах с 1 по 6) была изменена на "ДА", сможет ли другой код удалить эту строку из таблицы 7?

В некоторых случаях рабочие листы с 1 по 6 представляют собой список заданий, а «ДА» и «НЕТ» , если клиент заплатил. Если «НЕТ», они добавляются в список должников на рабочем листе 7. Если «ДА», их необходимо удалить из списка должников.

Answer 1

Этот код поможет вам:

Public Sub debtors()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wksdest As Worksheet
    Set wkb = ThisWorkbook
    Set wksdest = wkb.Sheets("Sheet7")
    wksdest.Rows.Clear 'Clear the contents of Sheet7
    destRow = 1 'First row on Sheet7
    For i = 1 To 6 'Loop through Sheets 1 to 6
        newIndex = Right(Str(i), 1)
        thisSheet = "Sheet" + newIndex
        Set wks = wkb.Sheets(thisSheet)
        wks.Activate
        'Selects column I
        Columns("I:I").Select
        'Find a coincidence with the string "NO"
        Set cell = Selection.Find(What:="NO", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        'If there is a coincidence (is Not Nothing)
        If Not cell Is Nothing Then
            firstRow = cell.Row
            newRow = cell.Row
            'Copy the row and paste on Sheet7
            wks.Rows(newRow).Copy
            wksdest.Rows(destRow).PasteSpecial xlPasteValues
            destRow = destRow + 1
            foundValue = True
            'Find next coincidences in the same sheet
            While foundValue
                Set cell = Selection.FindNext(cell)
                If Not cell Is Nothing Then
                    newRow = cell.Row
                    If newRow <> firstRow Then
                        wks.Rows(newRow).Copy
                        wksdest.Rows(destRow).PasteSpecial xlPasteValues
                        destRow = destRow + 1
                    Else
                        foundValue = False
                    End If
                Else
                    foundValue = False
                End If
            Wend
        End If
    Next i
    wksdest.Activate
End Sub

Откройте VBA/Macros с помощью ALT+F11, в ThisWorkbook вставьте новый модуль и вставьте код с правой стороны.

Выполните это, щелкая зеленый треугольник.

Я добавил комментарии к коду, чтобы вы поняли, как он работает.

Вы также можете запустить его шаг за шагом, нажав на первую строку, а затем пройдитесь по каждому шагу, нажав F8.