Блог

Я пытаюсь удалить ВСЕ повторяющиеся строки на основе столбца B и оставить только уникальные строки, но, похоже, он оставит 1 повторяющуюся запись, несмотря ни на что. Я пробовал с > 1 и = 2, но, похоже, это не работает. Любая помощь будет признательна.

 Sub test1()

    Dim fName As String, fPath As String, wb As Workbook, sh As Worksheet, i As Long, lCopyLastRow As Long, lDestLastRow As Long
    Set sh = ActiveSheet
    fPath = ThisWorkbook.Path amp; ""
    fName = Dir(fPath amp; "*.xls*")
    
    Do
        If fName <> ThisWorkbook.Name Then
        
            Set wb = Workbooks.Open(fPath amp; fName)
            lCopyLastRow = wb.Sheets(1).Cells(wb.Sheets(1).Rows.Count, "A").End(xlUp).Row
            lDestLastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1).Row
            wb.Sheets(1).Range("A2:AA1000" amp; lCopyLastRow).Copy sh.Range("B" amp; lDestLastRow)
            sh.Range("A1") = "Source"
            
            With sh
                .Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
            End With
            wb.Close
            
        End If
        
        Set wb = Nothing
        fName = Dir
        
    Loop Until fName = ""
    
    For i = sh.UsedRange.Rows.Count To 2 Step -1
        If Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value) > 1 Then Rows(i).Delete
    Next
End Sub
 

Проблема с вашим кодом в том, что вы countIf в оставшихся строках — если вы уже удалили «другие» дубликаты, первое значение является уникальным в оставшемся списке.

Поэтому вам нужно посчитать случаи, прежде чем удалять.

 Sub removeNonUniqueRows()

Dim arrCountOccurences As Variant
ReDim arrCountOccurences(2 To sh.UsedRange.Rows.Count)

Dim i As Long
For i = 2 To sh.UsedRange.Rows.Count
    arrCountOccurences(i) = Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value)
Next

For i = sh.UsedRange.Rows.Count To 2 Step -1
    If arrCountOccurences(i) > 1 Then sh.Rows(i).Delete
Next
End Sub