Question

我想比较Sheet1列A值和Sheet2列B，如果匹配，那么我想将Sheet1列A值放在Sheet2列C中。和列D应填充'True' 所以我写了下面的代码：

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

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

1 个答案: