大神求助

正宗新手

大神们求助：写了循环匹配数据，但是由于实际数据非常多，每次都是报表卡死了
两张表大概各有几十万行数据，另外第一张表里的列有几百列。





Sub 匹配数据并写入()

    Dim wsSource As Worksheet
    Dim wsInventory As Worksheet
    Dim lastRowSource As Long
    Dim lastRowInventory As Long
    Dim i As Long, j As Long, x As Long
   
   
    ' 设置数据源表和库存批次数据表
    Set wsSource = ThisWorkbook.Sheets("数据源")
    Set wsInventory = ThisWorkbook.Sheets("库存批次数据")
   
    ' 获取数据源表和库存批次数据表的最后一行和最后一列
    lastRowSource = wsSource.Cells(Rows.Count, "A").End(xlUp).Row
    lastRowInventory = wsInventory.Cells(Rows.Count, "A").End(xlUp).Row
    lastColumn = wsInventory.Cells(3, wsInventory.Columns.Count).End(xlToLeft).Column
    ' 循环查找匹配数据
   
   
    For x = 8 To lastColumn '从第八列开始
     For i = 2 To lastRowSource ' 第一行为标题行，从第二行开始
      For j = 2 To lastRowInventory ' 第一行为标题行，从第二行开始
        If wsInventory.Cells(3, x).Value = wsSource.Cells(i, 4).Value And _
           wsInventory.Cells(j, 1).Value = wsSource.Cells(i, 5).Value And _
           wsInventory.Cells(j, 3).Value = wsSource.Cells(i, 1).Value Then
           
   
                ' 将数据源表对应的C列数据写入库存批次数据表对应的单元格
                wsInventory.Cells(j, x).Value = wsSource.Cells(i, 3).Value
         End If
      Next j
    Next i
Next x
End Sub

鄂龙蒙

用数组要快点了

caffish

用个字典就解决的事情，何必要两表对比呢，你这个算法比较大的问题在于任一一行都要在数据源表里全部循环结束，这就大大增加了查找的时间，要不就是一旦查到数据就退出循环，但是依然不够快，直接用字典，几十万行我预估跑完时间不会超过2分钟，以下代码请参考

Sub 匹配数据2()
Dim arr(), brr(), crr(), d As Object

arr = Sheet1.Range("a3").CurrentRegion '将库存格式存在数组arr中

brr = Sheet2.Range("a1").CurrentRegion '将数据源存在数组brr中

Set d = CreateObject("scripting.dictionary") '建立一个存储到货日期和数量的字典

For i = 2 To UBound(brr)

d(brr(i, 5) & "|" & brr(i, 1) & "|" & brr(i, 4)) = brr(i, 3) '将仓库名称&三方编号&生产日期作为key值，生产数量作为item值存入字典

Next


For i1 = 2 To UBound(arr)

   For j = 8 To UBound(arr, 2)
   
   arr(i1, j) = d(arr(i1, 1) & "|" & arr(i1, 3) & "|" & arr(1, j))
   
   Next
Next


Sheet1.Columns(3).NumberFormatLocal = "@"


Sheet1.Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.29
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据源")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s1 = arr(i, 4)
    
11.         d1(s1) = ""
    
12.         s = arr(i, 5) & "|" & CStr(arr(i, 1)) & "|" & CDate(arr(i, 4))
    
13.         d(s) = arr(i, 3)
    
14.     Next
    
15.     ReDim brr(1 To d.Count, 1 To 3)
    
16.     For Each k In d.keys
    
17.         m = m + 1
    
18.         brr(m, 1) = Split(k, "|")(0)
    
19.         brr(m, 3) = Split(k, "|")(1)
    
20.     Next
    
21.     t = d1.keys
    
22.     sort1 t, True
    
23.     With Sheets("库存批次数据")
    
24.         .UsedRange.Offset(1, 7).ClearContents
    
25.         .Cells(3, 8).Resize(1, d1.Count) = t
    
26.         .Columns(3).NumberFormatLocal = "@"
    
27.         .[a4].Resize(m, 3) = brr
    
28.         arr = .UsedRange
    
29.         For i = 2 To UBound(arr)
    
30.             For j = 8 To UBound(arr, 2)
    
31.                 s = arr(i, 1) & "|" & CStr(arr(i, 3)) & "|" & CDate(arr(1, j))
    
32.                 If d.exists(s) Then
    
33.                     arr(i, j) = d(s)
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.         .UsedRange = arr
    
38.     End With
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub

复制代码