Удалить строки, если они существуют на другом листе - PullRequest
0 голосов
/ 24 октября 2019

Я пытаюсь найти в sheet_A значения в sheet_B / столбце A (начиная с A2), и если они существуют в sheet_A (столбец C, начиная с C2), они удаляются из sheet_A.

Sub Remover_Duplicados()

    'Backup to another sheet
    Const strSheetName As String = "BKP_sheet"
    Set wsTest = Nothing
    On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
    On Error GoTo 0

    If wsTest Is Nothing Then
        Worksheets.Add.Name = strSheetName
    End If
    Sheets("sheet_A").Range("A1:BK3500").Copy Destination:=Sheets(strSheetName).Range("A1")

    'Search and destroy
    Dim searchableRange As Range
    Dim toRemoveRange As Range
    Dim lLoop As Long

    Set searchableRange = Worksheets("sheet_B").Range("A2", "A3500")
    Set toRemoveRange = Worksheets("sheet_A").Range("C2", "C3500")

    For lLoop = searchableRange.Rows.Count To 2 Step -1
        If WorksheetFunction.CountIf(searchableRange, toRemoveRange(lLoop).Value) > 0 Then
            Worksheets("sheet_A").Rows(lLoop).Delete shift:=xlUp
        End If
    Next lLoop
End Sub

Лист A, B и результат: result

Некоторые не удаляются.

1 Ответ

1 голос
/ 24 октября 2019

Я просмотрел ваш код и немного изменил его, чтобы он был более динамичным с диапазонами. Я также использовал массив для заполнения значений, которые нужно удалить, а затем зациклил этот массив, чтобы решить, следует ли удалять строку. или нет:

Sub Remover_Duplicados()

    'Backup to another sheet
    Const strSheetName As String = "BKP_sheet"
    Dim wsA As Worksheet: Set wsA = ThisWorkbook.Worksheets("Sheet_A")
    Dim wsB As Worksheet: Set wsB = ThisWorkbook.Worksheets("Sheet_B")
    Dim arrToRemove()

    Set wsTest = Nothing
    On Error Resume Next
        Set wsTest = ThisWorkbook.Worksheets(strSheetName)
    On Error GoTo 0

    If wsTest Is Nothing Then
        Worksheets.Add.Name = strSheetName
    End If

    LastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
    wsA.Range("A1:BK" & LastRowA).Copy Destination:=Sheets(strSheetName).Range("A1")

    LastRowB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    arrToRemove = wsB.Range("A2:A" & LastRowB).Value

    For iRow = LastRowA To 2 Step -1
        For iArray = LBound(arrToRemove) To UBound(arrToRemove)
            If wsA.Cells(iRow, "C").Value = arrToRemove(iArray, 1) Then
                wsA.Rows(iRow).EntireRow.Delete shift:=xlUp
            End If
        Next iArray
    Next iRow
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...