比较Sheet1列A值与Sheet2列B如果匹配然后Sheet2.Col C = Sheet1.Col A和Sheet2.Col D = True

Question

我想比较Sheet1列A值与Sheet2列B，如果匹配then我希望把工作表Sheet1列A值在Sheet2中列C. 和列d应与“真” 所以我写了下面的代码来填充：

Sub val() 
Dim sheet1_last_rec_cnt As Long 
Dim sheet2_last_rec_cnt As Long 
Dim sheet1_col1_val As String 
Dim cnt1 As Long 
Dim cnt2 As Long 
sheet1_last_rec_cnt = Sheet1.UsedRange.Rows.Count 
sheet2_last_rec_cnt = Sheet2.UsedRange.Rows.Count 
For cnt1 = 2 To sheet1_last_rec_cnt 
sheet1_col1_val = Sheet1.Range("A" & cnt1).Value 
For cnt2 = 2 To sheet2_last_rec_cnt 
If sheet1_col1_val = Sheet2.Range("B" & cnt2).Value Then 
Sheet2.Range("C" & cnt2).Value = sheet1_col1_val 
Sheet2.Range("D" & cnt2).Value = "True" 
Exit For 
End If 
Next 
Next 
End Sub 

问题是，我有一个数以百万计的记录两张纸。 如果我使用上面的代码，那么For循环正在运行（一百万*一百万）次。所以，excel就像任何东西一样挂着。 有人可以帮我优化代码吗？

Answer 1

对于100万条记录我不确定Excel是存储此数据的最佳位置。如果您的代码旨在整理数据，以便您可以将其导出到数据库，那么很好...如果不是，那么，我担心您会遇到波涛汹涌的大海。

下面的代码将加快事情的速度，因为它只循环一次每列，并且它填充了一个唯一值的集合，因此它只需要每次检查而不是整列。如果你排序你的行，那么它可以做得更快，但我会留给你一个。

Public Sub RunMe() 
    Dim uniques As Collection 
    Dim sourceValues As Variant 
    Dim targetValues As Variant 
    Dim sourceItem As String 
    Dim targetItem As String 
    Dim sourceCount As Long 
    Dim targetCount As Long 
    Dim matches As Boolean 
    Dim output() As Variant 

    ' Acquire the values to be compared. 
    With ThisWorkbook.Worksheets("Sheet1") 
     sourceValues = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2 
    End With 
    With ThisWorkbook.Worksheets("Sheet2") 
     targetValues = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2 
    End With 

    'Resize the output array to size of target values array. 
    ReDim output(1 To UBound(targetValues, 1), 1 To 2) 

    sourceCount = 1 
    Set uniques = New Collection 

    'Iterate through the target values to find a match in the source values 
    For targetCount = 1 To UBound(targetValues, 1) 

     targetItem = CStr(targetValues(targetCount, 1)) 
     matches = Contains(uniques, targetItem) 

     If Not matches Then 

      'Continue down the source sheet to check the values. 
      Do While sourceCount <= UBound(sourceValues, 1) 

       sourceItem = CStr(sourceValues(sourceCount, 1)) 
       sourceCount = sourceCount + 1 

       'Add any new values to the collection. 
       If Not Contains(uniques, sourceItem) Then uniques.Add True, sourceItem 

       'Check for a match and leave the loop if we found one. 
       If sourceItem = targetItem Then 
        matches = True 
        Exit Do 
       End If 

      Loop 

     End If 

     'Update the output array if there's a match. 
     If matches Then 
      output(targetCount, 1) = targetItem 
      output(targetCount, 2) = True 
     End If 

    Next 

    'Write output array to the target sheet. 
    ThisWorkbook.Worksheets("Sheet2").Range("C2").Resize(UBound(targetValues, 1), 2).value = output 

End Sub 
Private Function Contains(col As Collection, key As String) As Boolean 
    'Function to test if the key already exists. 
    Contains = False 
    On Error Resume Next 
    Contains = col(key) 
    On Error GoTo 0 
End Function