Macro Advice - Colar linhas em uma nova planilha, se determinadas células lerem “NO”

Question

Gostaria de receber alguns conselhos usando o VBA e as macros.

Eu gostaria de vincular planilhas ( planilhas 1 a 6 ) com uma planilha mestre ( planilha 7 ).

Se a linha contiver "NO" na coluna I (em todas as planilhas 1 a 6 ), o código poderá copiar e colar essa linha na planilha 7 ?

Em seguida, se a linha (em planilhas 1 a 6 ) foi alterada para "YES" , outro código poderá excluir essa linha da planilha 7 ?

Para algum contexto, as planilhas 1 a 6 são uma lista de tarefas e as 'SIM' & 'NÃO' é se o cliente pagou. Se 'NO' eles são adicionados à lista de devedores na planilha 7 . Se 'YES' eles precisam ser removidos da lista de devedores.

    

Answer 1

Este código irá ajudá-lo:

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

Abra VBA / Macros com ALT + F11 , em ThisWorkbook insira um novo módulo e cole o código no lado direito.

Execute clicando no triângulo verde.

Eu coloco comentários no código para que você entenda como funciona.

Você pode executá-lo também passo a passo clicando na primeira linha e depois passando por cada etapa pressionando F8 .