Как быстро удалить дубликаты между двумя листами Excel VBA

excel vba excel-vba

6249 просмотра

2 ответа

Я использую vba, и у меня есть два листа, один из которых называется «Не звонить», и в столбце А содержится около 800 000 строк данных. Я хочу использовать эти данные для проверки столбца I на втором листе с именем «Лист1». Если он найдет совпадение, я хочу удалить всю строку в «Лист1». Я адаптировал код, который нашел из аналогичного вопроса: формула Excel для перекрестной ссылки на 2 листа, удаления дубликатов с одного листа и запуска его, но ничего не происходит. Я не получаю никаких ошибок, но он не работает.

Вот код, который я сейчас пытаюсь и не знаю, почему он не работает

Option Explicit
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String

Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
Dim strValueA As String


keyColA = "A"
keyColB = "I"

intRowCounterA = 1
intRowCounterB = 1

Set wsA = Worksheets("Do Not Call")
Set wsB = Worksheets("Sheet1")

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    strValueA = rngA.Value
    If Not dict.Exists(strValueA) Then
        dict.Add strValueA, 1
    End If
    intRowCounterA = intRowCounterA + 1
Loop

intRowCounterB = 1
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
    Set rngB = wsB.Range(keyColB & intRowCounterB)
    If dict.Exists(rngB.Value) Then
         wsB.Rows(intRowCounterB).delete
         intRowCounterB = intRowCounterB - 1
    End If
    intRowCounterB = intRowCounterB + 1
Loop
End Sub

Я прошу прощения, если вышеупомянутый код не находится в теге кода. Я впервые публикую код в Интернете, и я понятия не имею, правильно ли я это сделал.

Автор: MainTank Источник Размещён: 12.11.2019 09:12

Ответы (2)


4 плюса

Решение

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

Option Explicit
Sub CleanDupes()
    Dim targetArray, searchArray
    Dim targetRange As Range
    Dim x As Long

    'Update these 4 lines if your target and search ranges change
    Dim TargetSheetName As String: TargetSheetName = "Sheet1"
    Dim TargetSheetColumn As String: TargetSheetColumn = "I"
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call"
    Dim SearchSheetColumn As String: SearchSheetColumn = "A"

    'Load target array
    With Sheets(TargetSheetName)
        Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
                .Range(TargetSheetColumn & Rows.Count).End(xlUp))
        targetArray = targetRange
    End With
    'Load Search Array
    With Sheets(SearchSheetName)
        searchArray = .Range(.Range(SearchSheetColumn & "1"), _
                .Range(SearchSheetColumn & Rows.Count).End(xlUp))
    End With


    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    'Populate dictionary from search array
    If IsArray(searchArray) Then
        For x = 1 To UBound(searchArray)
            If Not dict.exists(searchArray(x, 1)) Then
                dict.Add searchArray(x, 1), 1
            End If
        Next
    Else
        If Not dict.exists(searchArray) Then
            dict.Add searchArray, 1
        End If
    End If

    'Delete rows with values found in dictionary
    If IsArray(targetArray) Then
        'Step backwards to avoid deleting the wrong rows.
        For x = UBound(targetArray) To 1 Step -1
            If dict.exists(targetArray(x, 1)) Then
                targetRange.Cells(x).EntireRow.Delete
            End If
        Next
    Else
        If dict.exists(targetArray) Then
            targetRange.EntireRow.Delete
        End If
    End If
End Sub

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

'Checks to see if the particular cell is empty.
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    'Stores the cell to a range for no good reason.
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    'Converts the value of the cell to a string because strValueA is a string.
    strValueA = rngA.Value
    'Checks to see if the string is in the dictionary.
    If Not dict.Exists(strValueA) Then
        'Adds the string to the dictionary.
        dict.Add strValueA, 1
    End If

Тогда позже:

 'checks the value, not the value converted to a string.
 If dict.Exists(rngB.Value) Then 

Это терпит неудачу, потому что Словарь сценариев не считает, что двойное число равно строке, даже если они были бы одинаковыми, если бы двойное число было преобразовано в строку.

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

If dict.Exists(cstr(rngB.Value)) Then

Или вы можете изменить Dim strValueA As Stringна Dim strValueA.

Автор: Daniel Размещён: 02.12.2012 01:55

0 плюса

Поскольку у меня было время, вот переписывание отказа от словаря и использование функции листа. (Вдохновлено комментарием Vlookup). Я не уверен, что будет быстрее.

Sub CleanDupes()
    Dim targetRange As Range, searchRange As Range
    Dim targetArray
    Dim x As Long
    'Update these 4 lines if your target and search ranges change
    Dim TargetSheetName As String: TargetSheetName = "Sheet1"
    Dim TargetSheetColumn As String: TargetSheetColumn = "I"
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call"
    Dim SearchSheetColumn As String: SearchSheetColumn = "A"

    'Load target array
    With Sheets(TargetSheetName)
        Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
                .Range(TargetSheetColumn & Rows.Count).End(xlUp))
        targetArray = targetRange
    End With
    'Get Search Range
    With Sheets(SearchSheetName)
        Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
                .Range(SearchSheetColumn & Rows.Count).End(xlUp))
    End With
    If IsArray(targetArray) Then
        For x = UBound(targetArray) To 1 Step -1
            If Application.WorksheetFunction.CountIf(searchRange, _
                                        targetArray(x, 1)) Then
                targetRange.Cells(x).EntireRow.Delete
            End If
        Next
    Else
        If Application.WorksheetFunction.CountIf(searchRange, targetArray) Then
            targetRange.EntireRow.Delete
        End If
    End If
End Sub
Автор: Daniel Размещён: 02.12.2012 05:00
32x32