Question

我需要比较不同表格中的2个单元格，如果匹配则得到一个值。我目前有这段代码，列B中的每个单元格都被检查到A列中的每个单元格，如果匹配，则复制C列中的相应单元格。到目前为止一直很好，问题是，这需要很长时间。我在B列只有750条记录，A列只有4000条记录。

有没有办法优化代码，以便运行得更快？

For i = 2 To LastRow
    For j = 2 To LastRowJ
        If Sheets("tempsheet").Range("B" & i).Value = Sheets("tempsheet").Range("A" & j).Value Then
            Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
        End If
    Next j
Next i

Answer 1

以下是6次测量：

1. copyValsCell1():    90.78125 sec (posted code)
2. copyValsCell2():    53.27343 sec (ws object)
3. copyValsCell3():    52.67187 sec (With statement, and screen off)

4. copyValsArr():       0.60937 sec (Array - no restrictions)

5. copyValsDictCell():  0.07812 sec (Dictionary with Range - unique values only)
6. copyValsDictArr():   0.03125 sec (Dictionary with Array - unique values only)

在我的测试文件中，我将所有值都放在同一张纸上（lr = 4000: lrj = 750）

初始代码 - Duration copyValsCell1(): 90.78125 sec

ws object

Set ws = Sheets("tempsheet")
For i = 2 To lr                             'Duration copyValsCell2(): 53.2734375 sec
    For j = 2 To lrj
        If ws.Range("B" & i).Value = ws.Range("A" & j).Value Then
            ws.Range("Q" & i).Value = ws.Range("C" & j).Value
        End If
    Next
Next

使用声明，屏幕关闭

Set ws = Sheets("tempsheet")
Application.ScreenUpdating = False
For i = 2 To lr                             'Duration copyValsCell3(): 52.671875 sec
    For j = 2 To lrj
        With ws
            If .Range("B" & i).Value2 = .Range("A" & j).Value2 Then
                .Range("Q" & i).Value2 = .Range("C" & j).Value2
            End If
        End With
    Next
Next
Application.ScreenUpdating = True

阵列

Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
For i = 2 To lr                             'Duration copyValsArr(): 0.609375 sec
    For j = 2 To lrj
        If v(i, 2) = v(j, 1) Then v(i, 17) = v(j, 3)
    Next
Next
Sheets("tempsheet").Range("A1:Q4000") = v

带范围的字典（需要引用Microsoft Scripting Runtime库）

Set d = New Dictionary: Set ws = Sheets("tempsheet")
For i = 2 To lrj                            'Duration copyValsDictCell(): 0.078125 sec
    d(ws.Range("A" & i).Value2) = i
Next
For i = 2 To lr
    If d.Exists(ws.Range("B" & i).Value) Then
        ws.Range("Q" & i).Value = ws.Range("C" & d(ws.Range("B" & i).Value)).Value
    End If
Next

包含Array的字典（需要引用Microsoft Scripting Runtime库）

Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
Set d = New Dictionary                      'Duration copyValsDictArr(): 0.03125 sec
For i = 2 To lrj
    d(v(i, 1)) = i
Next
For i = 2 To lr
    If d.Exists(v(i, 2)) Then v(i, 17) = v(d(v(i, 2)), 3)
Next
Sheets("tempsheet").Range("A1:Q4000") = v

Answer 2

试试这个：

For i = 2 To LastRow
    Set match_check = Sheets("tempsheet").Range("A:A").Find(Sheets("tempsheet").Range("B" & i), Lookat:=xlWhole)
    If Not match_check Is Nothing Then Range("Q" & i) = match_check.Offset(0,2)
Next i

Find会返回列中第一个找到匹配项的Range个对象，如果找不到匹配项，则返回Nothing。我没有检查运行时间，但它应该比双循环更快。

Answer 3

您可以使用键入字母A中值的字典 - 假设这些值都是不同的（否则您的代码本身就没有意义。包含对 Microsoft Scripting Runtime 的引用（通过VBA编辑器中的Tools/References）。以下代码的速度应该是目前的100倍：

Sub test()
    Dim LastRow As Long, LastRowJ As Long
    Dim i As Long, j As Long
    Dim AVals As New Dictionary

    LastRow = Sheets("tempsheet").Cells(Rows.Count, "B").End(xlUp).Row()
    LastRowJ = Sheets("tempsheet").Cells(Rows.Count, "A").End(xlUp).Row()
    For j = 2 To LastRowJ
        AVals.Add Sheets("tempsheet").Range("A" & j).Value, j
    Next j
    For i = 2 To LastRow
        If AVals.Exists(Sheets("tempsheet").Range("B" & i).Value) Then
            j = AVals(Sheets("tempsheet").Range("B" & i).Value)
            Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
        End If
    Next i
End Sub

双FOR循环需要一段时间才能完成

3 个答案: