Question

我的代码可以工作，但是在工作表1上的36000行和工作表2上的10000上执行需要3个多小时。我想另一种方法来更改两个单元格相等的另一个工作表中的两个单元格数据。

Sub test_function()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    line_count1 = ws1.Range("A1").End(xlDown).row
    line_count2 = ws2.Range("A1").End(xlDown).row

    For i = 2 To line_count1
        For j = 2 To line_count2

        If CStr(ws1.Range("d" & i).Value) = CStr(ws2.Range("c" & j).Value) And CStr(ws1.Range("f" & i).Value) = CStr(ws2.Range("e" & j).Value) Then
            ws1.Range("q" & i).Value = ws2.Range("a" & j).Value
            ws1.Range("r" & i).Value = ws2.Range("b" & j).Value
        End If

        Next j
    Next i
End Sub

Answer 1

试试这个：

Sub test_function()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    line_count1 = ws1.Range("A1").End(xlDown).Row
    line_count2 = ws2.Range("A1").End(xlDown).Row

    Dim r2() As Variant
    Dim r1() As Variant

    ' get all data from both ranges
    r2 = ws2.Range("a2:e" & line_count2)
    r1 = ws1.Range("d2:r" & line_count1)

    For i = 2 To line_count1
        For j = 2 To line_count2

        If CStr(r1(1, i)) = CStr(r2(3, j)) And CStr(r1(3, i)) = CStr(r2(5, j)) Then
            r1(13, i) = r2(1, j)
            r1(14, i) = r2(2, j)
        End If

        Next j
    Next i

    'paste the changed range1 back
    ws1.Range("d2:r" & line_count1) = r1
End Sub

这显示了如何与原始代码执行相同的操作，但使用范围数组复制而不是浏览单个单元格。这不是最有效的方法（因为它仍在复制许多不必要的单元格），但它应该更快。

更新：

好的，现在这个版本可能在这个任务上尽可能快：

Sub Fast_test_function()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    line_count1 = ws1.Range("A1").End(xlDown).Row
    line_count2 = ws2.Range("A1").End(xlDown).Row

    ' copy each needed column into an array
    Dim d1(), f1(), q1(), r1(), c2(), e2(), a2(), b2()
    d1 = ws1.Range("d1:d" & line_count1)
    f1 = ws1.Range("f1:f" & line_count1)
    q1 = ws1.Range("q1:q" & line_count1)
    r1 = ws1.Range("r1:r" & line_count1)

    c2 = ws2.Range("c1:c" & line_count2)
    e2 = ws2.Range("e1:e" & line_count2)
    a2 = ws2.Range("a1:a" & line_count2)
    b2 = ws2.Range("b1:b" & line_count2)

    ' load the lookup collections
    Dim sKey As String, i As Long, j As Long, str As String
    Dim colA2 As New Collection, colB2 As New Collection

    On Error Resume Next    ' ignore duplicate key errors
    For j = 2 To line_count2
        sKey = CStr(c2(j)) & "~" & CStr(e2(j))
        colA2.Add CStr(a2(j)), sKey
        colB2.Add CStr(b2(j)), sKey
    Next j

    ' set the output array values
    For i = 2 To line_count1
        sKey = CStr(d1(i)) & "~" & CStr(f1(i))
        On Error Resume Next    ' suppress Missing Key errors
        str = colA2(sKey)
        If Err.Number = 0 Then
            q1(i) = str
            str = colB2(sKey)
            r1(i) = str
        End If
    Next i
    On Error GoTo 0

    ' copy the output arrays back to the output ranges
    ws1.Range("q1:q" & line_count1) = q1
    ws1.Range("r1:r" & line_count1) = r1
End Sub

虽然使用Dictionaries而不是Collections的版本可能会稍快一些。

Answer 2

你正在进行360,000次个人比较，这将会很慢。

您好像正在寻找上一次ws1 col D中的值出现在ws1 col C中，然后将某些内容从ws2复制到ws1。

ws1中至少有26,000行没有找到答案，并且有一些方法可以找到一行是否是其中之一而无需循环进行10,000次比较。

作为第一步，而不是让代码获取ws1 D中的值？ 10,000次，将其放在变量中，然后将该变量与ws2进行比较

还值得在变量中保存ws2 col C的最小值和最大值，并使用它们来简化筛选。

Answer 3

想法是先对两个列表进行预先排序，然后在排序列表中搜索要快得多，因为您不必重新开始，只要达到等于或大于您的值，就可以停止寻找。

以下代码适用于4列中的数据 - A, B, C, D，它会在A和B上的Sheet1和Sheet2列中查找匹配项然后将Sheet2列C和D中的值复制到Sheet1列E和F。将其调整为您将使用的任何列。对于Sheet1上的36000行和Sheet2上的10000行，总时间少于5秒。

守则：

Sub test_function()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    ws1.Sort.SortFields.Clear
    ws1.Sort.SortFields.Add Key:=Range( _
        "A2:A36000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ws1.Sort.SortFields.Add Key:=Range( _
        "B2:B36000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ws1.Sort
        .SetRange Range("A2:D36000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ws2.Sort.SortFields.Clear
    ws2.Sort.SortFields.Add Key:=Range( _
        "A2:A36000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ws2.Sort.SortFields.Add Key:=Range( _
        "B2:B36000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ws2.Sort
        .SetRange Range("A2:D36000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    i = 2
    j = 2
    Do While ws1.Cells(i, "A") <> ""
        Do While ws2.Cells(j, "A") <> "" And ws2.Cells(j, "A") < ws1.Cells(i, "A")
            j = j + 1
        Loop
        If ws2.Cells(j, "A") = ws1.Cells(i, "A") And ws2.Cells(j, "B") = ws1.Cells(i, "B") Then
            ws1.Cells(i, "E") = ws2.Cells(j, "C")
            ws1.Cells(i, "F") = ws2.Cells(j, "D")
        End If
        i = i + 1
    Loop
End Sub

如果第一列中的值包含多个重复值，则可以对此进行优化以便正确处理。

VBA优化工作表数据传输

3 个答案: