Быстрый метод сравнения из 2 столбцов

EDIT: Вместо этого для моего решения используйте что-то вроде

 For i = 1 To tmpRngSrcMax
     If rngSrc(i) <> rngDes(i) Then ...
 Next i

Это примерно в 100 раз быстрее.

Мне нужно сравнить два столбца, содержащие строковые данные, используя VBA. Это мой подход:

Set rngDes = wsDes.Range("A2:A" & wsDes.Cells(Rows.Count, 1).End(xlUp).Row)
Set rngSrc = wsSrc.Range("I3:I" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row)

tmpRngSrcMax = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
cntNewItems = 0

For Each x In rngSrc

tmpFound = Application.WorksheetFunction.CountIf(rngDes, x.Row)
Application.StatusBar = "Processed: " & x.Row & " of " & tmpRngSrcMax & " / " & Format(x.Row / tmpRngSrcMax, "Percent")
DoEvents ' keeps Excel away from the "Not responding" state

If tmpFound = 0 Then ' new item
    cntNewItems = cntNewItems + 1

    tmpLastRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row + 1  ' first empty row on target sheet
    wsDes.Cells(tmpLastRow, 1) = wsSrc.Cells(x.Row, 9)
End If
Next x

Итак, я использую цикл For Each для итерации по столбцу 1-го (src) и метода CountIf, чтобы проверить, присутствует ли элемент во втором столбце (des). Если нет, скопируйте в конец столбца 1 (src).

Код работает, но на моей машине требуется ~ 200 с заданных столбцов размером около 7000 строк. Я заметил, что CountIf работает быстрее, когда используется напрямую в качестве формулы.

Есть ли идеи для оптимизации кода?

ОТВЕТЫ

Ответ 1

Ok. Позвольте прояснить несколько вещей.

Таким образом, столбец A имеет 10,000 случайно сгенерированные значения, столбец I имеет 5000 случайно сгенерированные значения. Похоже на это

enter image description here

Я выполнил 3 разных кода против 10 000 ячеек.

подход for i = 1 to ... for j = 1 to ..., тот, который вы предлагаете

Sub ForLoop()

Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim lastA As Long
    lastA = Range("A" & Rows.Count).End(xlUp).Row

    Dim lastB As Long
    lastB = Range("I" & Rows.Count).End(xlUp).Row

    Dim match As Boolean

    Dim i As Long, j As Long
    Dim r1 As Range, r2 As Range
    For i = 2 To lastA
        Set r1 = Range("A" & i)
        match = False
        For j = 3 To lastB
            Set r2 = Range("I" & j)
            If r1 = r2 Then
                match = True
            End If
        Next j
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = r1
        End If
    Next i

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

Оценка Sid

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

my (mehow) подход

Sub Main()
Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

    Dim varr As Variant
    varr = Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row).Value

    Dim x, y, match As Boolean
    For Each x In arr
        match = False
        For Each y In varr
            If x = y Then match = True
        Next y
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = x
        End If
    Next

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

результаты следующим образом

enter image description here

теперь вы выбираете метод быстрого сравнения:)

заполнение случайных значений

Sub FillRandom()
    Cells.ClearContents
    Range("A1") = "Column A"
    Range("I2") = "Column I"

    Dim i As Long
    For i = 2 To 10002
        Range("A" & i) = Int((10002 - 2 + 1) * Rnd + 2)
        If i < 5000 Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = _ 
                 Int((10002 - 2 + 1) * Rnd + 2)
        End If
    Next i

End Sub

Ответ 2

Вот код без цикла, который выполняется почти мгновенно для приведенного выше примера из mehow.

Sub HTH()

    Application.ScreenUpdating = False

    With Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 1)
        .Formula = "=VLOOKUP(A2,I:I,1,FALSE)"
        .Value = .Value
        .SpecialCells(xlCellTypeConstants, 16).Offset(, -1).Copy Range("I" & Rows.Count).End(xlUp).Offset(1)
        .ClearContents
    End With

    Application.ScreenUpdating = True

End Sub

Вы можете использовать любой столбец, который вам нравится, в качестве фиктивного столбца.

Info: Готово попасть в цикл

Некоторые примечания по тестированию скорости:
Скомпилируйте проект vba перед запуском теста.
Для каждого цикла выполняется быстрее, чем для я = от 1 до 10 циклов.
Если возможно, выйдите из цикла, если найден ответ, чтобы предотвратить бесполезные циклы с помощью Exit For.
Длинные выполняются быстрее, чем целые.

Наконец, более быстрый метод цикла (если вы должны зацикливать, но его все еще не так быстро, как выше описанный метод без цикла):

Sub Looping()
    Dim vLookup As Variant, vData As Variant, vOutput As Variant
    Dim x, y
    Dim nCount As Long
    Dim bMatch As Boolean

    Application.ScreenUpdating = False

    vData = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Value
    vLookup = Range("I2", Cells(Rows.Count, "I").End(xlUp)).Value

    ReDim vOutput(UBound(vData, 1), 0)

    For Each x In vData
        bMatch = False
        For Each y In vLookup
            If x = y Then
                bMatch = True: Exit For
            End If
        Next y
        If Not bMatch Then
            nCount = nCount + 1: vOutput(nCount, 0) = x
        End If
    Next x

    Range("I" & Rows.Count).End(xlUp).Offset(1).Resize(nCount).Value = vOutput

    Application.ScreenUpdating = True      

End Sub

В соответствии с @brettdj комментирует a Для следующей альтернативы:

For x = 1 To UBound(vData, 1)
    bMatch = False
    For y = 1 To UBound(vLookup, 1)
        If vData(x, 1) = vLookup(y, 1) Then
            bMatch = True: Exit For
        End If
    Next y
    If Not bMatch Then
        nCount = nCount + 1: vOutput(nCount, 0) = vData(x, 1)
    End If
Next x

Ответ 3

если вы используете .Value2 вместо .Value, это будет немного быстрее.

Ответ 4

Просто написал это быстро... Можете ли вы проверить это для меня?

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

Ответ 5

Я просто подстроил Mehow, чтобы получить элементы из обоих списков. На всякий случай кому-то может понадобиться. Спасибо за совместное использование кода

Sub Main()

Application.ScreenUpdating = False

Dim stNow As Date
stNow = Now

Dim varr As Variant
varr = Range("A2:A" & Range("A" & Rows.count).End(xlUp).row).Value

Dim arr As Variant
arr = Range("I3:I" & Range("I" & Rows.count).End(xlUp).row).Value

Dim x, y, match As Boolean
For Each y In arr
    match = False
    For Each x In varr
        If y = x Then match = True
    Next x
    If Not match Then

        Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = y

    End If
Next
Range("B1") = "Items not in A Lists"
Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = "Items not in I Lists"
'Dim arr As Variant
arr = Range("A3:A" & Range("A" & Rows.count).End(xlUp).row).Value

'Dim varr As Variant
varr = Range("I3:I" & Range("I" & Rows.count).End(xlUp).row).Value

'Dim x, y, match As Boolean
For Each x In arr
    match = False
    For Each y In varr
        If x = y Then match = True
    Next y
    If Not match Then
        Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = x
    End If
Next


Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True

End Sub

Ответ 6

Function Ranges_Iguais(rgR1 As Range, rgR2 As Range) As Boolean

  Dim vRg1 As Variant
  Dim vRg2 As Variant
  Dim i As Integer, j As Integer

  vRg1 = rgR1.Value
  vRg2 = rgR2.Value
  i = 0

  Do
    i = i + 1
    j = 0
    Do
        j = j + 1
    Loop Until vRg1(i, j) <> vRg2(i, j) Or j = UBound(vRg1, 2)
  Loop Until vRg1(i, j) <> vRg2(i, j) Or i = UBound(vRg1, 1)

  Ranges_Iguais = (vRg1(i, j) = vRg2(i, j))

End Function

Ответ 7

    Set R1 = Range(S1.Cells(1, 1), S1.Cells.SpecialCells(xlCellTypeLastCell))
    Set R2 = Range(S2.Cells(1, 1), S2.Cells.SpecialCells(xlCellTypeLastCell))
    If R1.Count = R2.Count Then
        Set R3 = Range(S3.Cells(1, 1), S3.Cells(S2.Cells.SpecialCells(xlCellTypeLastCell).Row, S2.Cells.SpecialCells(xlCellTypeLastCell).Column))
        R3.Formula = "=" & R1.Address(, , , True) & "=" & R2.Address(, , , True)
        Set R = R3.Find(What:="FALSE", After:=S3.Cells(1, 1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False)
        bComp = R Is Nothing
    Else
        bComp = False
    End If