Блог

У меня возникли проблемы с написанием макроса для сравнения нескольких столбцов на нескольких листах (одного и того же файла Excel). Я написал несколько, но они занимали так много времени, что Excel зависал.

Допустим, у меня есть 4 листа в одном файле. Лист1 с двумя столбцами (B и C) и 7000 строк. Лист2 пустой лист новые записи. Лист3 пустой лист для старых записей, но с некоторым обновленным значением / информацией. Лист4 представляет собой базу данных с 2 столбцами (A и B) и 22000 строками.

Мне нужно сравнить столбец A из листа 1 со столбцом B в листе 4. Если в столбце A sheet1 есть совершенно новые записи, скопируйте эту запись из столбца A sheet1 (и ее соответствующее значение из столбца B sheet1) в новую строку (столбцы A и B) в Sheet2. Если в столбце A Sheet1 есть записи, которые уже есть в столбце A sheet4, затем сравните их соответствующие значения в столбце B. Если комбинация столбца A столбца B из листа 1 находится в листе 4, игнорируйте ее. Если значение из столбца A Sheet1 находится в столбце A Sheet4, но их соответствующие значения в столбце B не совпадают, скопируйте столбец A столбец B из листа 1 в новую строку (столбцы A и B) в листе 3.

Надеюсь, это достаточно ясно. Из-за количества строк (7000 в Sheet1 для сравнения с 20000 в Sheet4) Я не могу написать макрос, который обрабатывает все меньше минуты.

Любая помощь?

Редактирование 1: я использовал код, предложенный @FaneDuru (спасибо!). но я сталкиваюсь с ошибкой: «Ошибка времени выполнения ‘457’: этот ключ уже связан с элементом этой коллекции» Это потому, что у меня много повторяющихся значений в одних и тех же столбцах?

Редактировать 2: похоже, что код «if not dict3.exists» не распознается VBA. Когда я набираю «.exists» с меньшей буквой и перехожу на другую строку, предполагается исправить ее на заглавную «.Exists», верно? Он этого не делает.

Редактировать 3: я провел еще несколько тестов. Я ставил разрывы и запускал код. Когда я ставлю разрыв в этой строке «If WorksheetFunction.CountIf(rngA4, arr1(i, 1))> 0 Тогда», ошибка не возникает. Когда я ставлю разрыв на одну строку ниже «Для j = UBound (arr4) До 1 шага -1» происходит ошибка.

Ошибка: «Ошибка времени выполнения ‘457’: этот ключ уже связан с элементом этой коллекции»

 Private Sub CommandButton1_Click()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim arr1, arr2, arr3, arr4, dict2 As Object, dict3 As Object, rngA4 As Range
Dim rngB4 As Range, i As Long, j As Long, lastR1 As Long, lastR4 As Long

lastR1 = Sheet1.Range("A" amp; Sheet1.Rows.Count).End(xlUp).Row
lastR4 = Sheet4.Range("A" amp; Sheet4.Rows.Count).End(xlUp).Row

Set rngA4 = Sheet4.Range("A2:A" amp; lastR4)
Set rngB4 = Sheet4.Range("B2:B" amp; lastR4)

arr1 = Sheet1.Range("B2:C" amp; lastR1).Value
arr4 = Sheet4.Range("A2:B" amp; lastR4).Value

Set dict2 = CreateObject("Scripting.Dictionary")
Set dict3 = CreateObject("Scripting.Dictionary")

For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4, arr1(i, 1)) = 0 Then
        dict2.Add arr1(i, 1), arr1(i, 2):
    End If
    If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i, 1) = arr4(j, 1) Then
                If arr1(i, 2) <> arr4(j, 2) Then
                    If arr1(i, 2) <> arr4(j, 2) Then
                        dict3.Add arr1(i, 1), arr1(i, 2): Exit For
                End If
            End If
        Next j
    End If
Next i

If dict2.Count > 0 Then
    arr2 = Application.Transpose(Array(dict2.keys, dict2.Items))
    Sheet2.Range("A2").Resize(dict2.Count, 2).Value = arr2
End If

If dict3.Count > 0 Then
    arr3 = Application.Transpose(Array(dict3.keys, dict3.Items))
    Sheet3.Range("A2").Resize(dict3.Count, 2).Value = arr3
End If

MsgBox "Done!"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub
 

Вы можете использовать формулу Excel countif, чтобы найти любую запись данных, которая не существует в вашем наборе данных.

Затем вы можете скопировать значение с помощью Sheets().Range().Value = Sheets().Range().Value на лист, где вы хотите получить свой вывод. Если выходной диапазон уже заполнен, вы можете использовать Sheets().Range().End(xlDown) .Адрес, чтобы найти адрес последней строки вашего выходного набора данных.

Вы перебираете все значения countif, которые возвращают 0, чтобы получить все недостающие данные.

Пожалуйста, протестируйте следующий код. Вы не ответили на уточняющие вопросы, и код предполагает, что существует не более одного вхождения, а обработанные листы загружаются путем добавления строк. Код работает независимо от этого аспекта, но если приведенное выше предположение верно, он будет выполняться быстрее:

 Sub testProcessNewEntries()
 Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
 Dim arr1, arr2, arr3, arr4, dict2 As Object, dict3 As Object, rngA4 As Range
 Dim rngB4 As Range, i As Long, j As Long, lastR1 As Long, lastR4 As Long
 
 Set sh1 = Worksheets("Sheet1") 'use here your first sheet
 Set sh2 = Worksheets("Sheet2") 'use here your second sheet
 Set sh3 = Worksheets("Sheet3") 'use here your third sheet
 Set sh4 = Worksheets("Sheet4") 'use here your fourth sheet
 
 lastR1 = sh1.Range("A" amp; sh1.Rows.count).End(xlUp).row
 lastR4 = sh4.Range("A" amp; sh4.Rows.count).End(xlUp).row
  
 Set rngA4 = sh4.Range("A2:A" amp; lastR4)
 Set rngB4 = sh4.Range("B2:B" amp; lastR4)
 
 arr1 = sh1.Range("A2:B" amp; lastR1).Value
 arr4 = sh4.Range("A2:B" amp; lastR4).Value
 
 Set dict2 = CreateObject("Scripting.Dictionary")
 Set dict3 = CreateObject("Scripting.Dictionary")
 
 For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4, arr1(i, 1)) = 0 Then
        dict2.Add arr1(i, 1), arr1(i, 2):
    End If
    If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i, 1) = arr4(j, 1) Then
                If arr1(i, 2) <> arr4(j, 2) Then
                    If Not dict3.Exists(arr1(i, 1)) Then
                        dict3.Add arr1(i, 1), arr1(i, 2): Exit For
                    End If
                End If
            End If
        Next j
    End If
 Next i
 
 If dict2.count > 0 Then
    arr2 = Application.Transpose(Array(dict2.Keys, dict2.Items))
    sh2.Range("A2").Resize(dict2.count, 2).Value = arr2
 End If
 If dict3.count > 0 Then
    arr3 = Application.Transpose(Array(dict3.Keys, dict3.Items))
    sh3.Range("A2").Resize(dict3.count, 2).Value = arr3
 End If
 MsgBox "Ready..."
End Sub