Excel VBA - 查找列中的匹配值和另一列中的 return 值

Question

我想判断工作簿1的H列和工作簿2的A列的值是否匹配，那么return工作簿1的S列对应行的“Y”是否匹配，“ N”表示不匹配。

但是，运行我当前的代码需要的时间非常长（> 15 分钟），有没有办法缩短它？

这是我当前的 VBA 代码：

Dim j, LastRow As Long
Dim answer, found As Range

LastRow = Workbooks("1.xlsx").Sheets("AA").Range("H" & Rows.Count).End(xlUp).Row

For j = 1 To LastRow
answer = Workbooks("1.xlsx").Sheets("AA").Range("H" & j).Value

Set found = Workbooks("2.xlsx").Sheets("BB").Columns("A:A").Find(what:=answer)

If found Is Nothing Then
    Workbooks("1.xlsx").Sheets("AA").Range("S" & j).Value = "N"
Else
    Workbooks("1.xlsx").Sheets("AA").Range("S" & j).Value = "Y"
End If

Next j

Answer 1

再次根据我的评论，您可以尝试禁用减慢 workbook/sheet 代码的 3 个关键播放器：

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

'''Your code here'''
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

不过，我尝试了一个数组版本，您可以在下面找到它。看看是否适合你。

Sub CompareWorkbooks()

Dim LRow1 As Long, LRow2 As Long, Arr1 As Variant, Arr2 As Variant
Dim i As Long, j As Long

LRow1 = Workbooks("1.xlsx").Sheets("AA").Range("H" & Rows.Count).End(xlUp).Row
LRow2 = Workbooks("2.xlsx").Sheets("BB").Range("A" & Rows.Count).End(xlUp).Row
Arr1 = Application.Transpose(Workbooks("1.xlsx").Sheets("AA").Range("H1:H" & LRow1).Value)
Arr2 = Application.Transpose(Workbooks("2.xlsx").Sheets("BB").Range("A1:A" & LRow2).Value)

For i = 1 To LRow1
    For j = 1 To LRow2
        If Arr1(i) = Arr2(j) Then
            Arr1(i) = "Y"
            Exit For
        End If
        If j = LRow2 Then
            Arr1(i) = "N"
        End If
    Next j
Next i

Workbooks("1.xlsx").Sheets("AA").Range("S1:S" & LRow1).Value = Application.Transpose(Arr1)

End Sub

它本质上是将两个范围加载到数组中。然后比较数组，如果找到匹配项，则用 Y 或 N 替换数组 1 的值。然后，一旦循环完成，它就会立即将更改的数组转储到您的列 S 中。因此在循环期间不会触及工作表，因为它全部在内存中完成，速度要快得多。我的电脑在大约一秒钟内完成了 2000 行数字。

Answer 2

请尝试下一个代码：

Sub matchData()
  Dim ws As Worksheet, ws2 As Worksheet, j, LastRow As Long, arrH, arrFin
  Dim answer, found As Range
  
  Set ws = Workbooks("1.xlsx").Sheets("AA")
  Set ws2 = Workbooks("2.xlsx").Sheets("BB")
  LastRow = ws.Range("H" & rows.count).End(xlUp).row
  
  arrH = ws.Range("H1:H" & LastRow).value 'put the range in an array to make the iteration faster
  ReDim arrFin(1 To UBound(arrH), 1 To 1) 'redim the array to receive the comparison result
  For j = 1 To UBound(arrH)
        answer = ws.Range("H" & j).value
        
        Set found = ws2.Columns("A:A").Find(what:=answer) 'faster than iteration even in an array...
        
        If found Is Nothing Then
            arrFin(j, 1) = "N"  'fill the array element with the appropriate string
        Else
            arrFin(j, 1) = "Y"  'fill the array element with the appropriate string
        End If
  Next j
  ws.Range("S1").Resize(UBound(arrFin), 1).value = arrFin 'drop the array content at once (very fast)
End Sub

我想收到一些关于其持续时间的反馈...

Excel VBA - 查找列中的匹配值和另一列中的 return 值

Excel VBA - Find matching values in columns and return value in another column

excel

vba

duration

match