Question

我正在运行sub，它将两个单元格（B和D /或字符串Received）从一张表（＆＃34; DATA＆＃34;）与另一张表格中的两个单元格（C，H）进行比较（＆＃34; Incoming_report＆＃34;），如果匹配则将I，G单元从Incoming转换为Data。

通过组合来自Incoming_report表的两个单元格并在Z列中写入新值来完成，例如＆＃34; 123456＆＃34;从C和H到f.e. ＆＃34; 123456Received＆＃34; （还有另外5种状态（收到，拒绝，发送......，但我只需要那些收到）

然后我从数据表B栏中获取示例123456和仅收到（可能还有其他5种状态，但我只需要收到的）

这对我来说很有意义且效果很好，但我必须在每张表中使用超过500k行。会发生什么 - 组合500,000次两个单元格并在Z列中搜索另一张表格中的另外500,000个可能的匹配，如果没有找到N / A，然后2组合，第3，第4 ......直到500,000。我添加了显示状态栏，我看到它的速度有多慢（每分钟只有900行，所以对于一个小的映射，它需要超过10个小时）。这是sub本身，任何人都可以分享如何改进它以使其更快地工作的想法吗？万分感谢。

Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
   Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
 x = Sheets("Data").Range("B" & i).Value & "Received"
 If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
   Sheets("Data").Range("L" & i) = "N/A"
   Sheets("Data").Range("M" & i) = "N/A"
 Else
   incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
   Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
   Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
 End If
 Next i
 End Sub

Answer 1

EDIT2：固定来源列：

Sub incoming_fetch()

    Dim i As Long, n As Long, z As Long, num As Long
    Dim x As String
    Dim shtIn As Worksheet, shtData As Worksheet
    Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
    Dim t

    Set dict = CreateObject("scripting.dictionary")

    Set shtIn = Sheets("Incoming_report")
    Set shtData = Sheets("Data")

    n = shtData.Range("A" & Rows.Count).End(xlUp).Row
    z = shtIn.Range("D" & Rows.Count).End(xlUp).Row

    t = Timer

    'get all values from Cols C, H, L, M
    arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
    arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
    arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
    arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value

    Debug.Print "Get Arrays: " & Timer - t
    t = Timer

    'create a lookup dictionary of all the ColC values
    '  (where ColH = "Received")
    num = UBound(arrC, 1)
    For i = 1 To num
        v = arrC(i, 1)
        If arrH(i, 1) = "Received" And Len(v) > 0 Then
            dict(v) = Array(arrI(i, 1), arrG(i, 1))
        End If
    Next i
    'free up some memory
    Erase arrC: Erase arrH: Erase arrI: Erase arrG

    Debug.Print "Filled dict: " & Timer - t
    t = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    On Error GoTo haveError

    For i = 3 To n

        If i Mod 500 = 0 Then Application.StatusBar = i
        x = shtData.Range("B" & i).Value

        If dict.exists(x) Then
            arr = dict(x)
            r1 = arr(0)
            r2 = arr(1)
        Else
            r1 = "N/A": r2 = "N/A"
        End If

        With shtData
            .Range("L" & i) = r1 
            .Range("M" & i) = r2 
        End With
    Next i

    Debug.Print "Done: " & Timer - t

haveError:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

EXCEL VBA：数据映射太慢

1 个答案: