时间戳

首页 > 解决方案 > VBA 优化工作表数据传输

excel - VBA 优化工作表数据传输

问题描述

我的代码有效，但在工作表 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

标签： excelvba

解决方案

尝试这个：

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

尽管使用字典而不是集合的版本可能会稍微快一些。

推荐阅读