利用字典和数组方法，把表1符合表2条件的行复制到表3中

cysczhumh

由于数据较多，想用字典+数组方法。程序运行了，表3中没见数据。

小凡、、、

上传下附件

醉眼看尘世

1. Sub test2() '字典+数组
   
2. Dim d, Arr, i&, s$, j&, hS&
   
3. Application.ScreenUpdating = False
   
4. t = Timer
   
5. Set d = CreateObject("scripting.dictionary")
   
6.     r = Sheet2.Cells(Rows.Count, 1).End(3).Row
   
7.     Arr = Sheet2.[a1].Resize(r, 2)
   
8.    
   
9.     For i = 2 To UBound(Arr)
   
10.         s = Arr(i, 2) & ""
    
11.         d(s) = ""
    
12.     Next
    
13.    
    
14.     r = Sheet1.Cells(Rows.Count, 1).End(3).Row
    
15.     Arr = Sheet1.[a1].Resize(r, 12)
    
16.     ReDim brr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    
17.     hS = 0
    
18.     For i = 2 To UBound(brr)
    
19.         
    
20.         If d.exists(Arr(i, 3) & "") Then
    
21.         hS = hS + 1
    
22.          For j = 1 To UBound(Arr, 2)
    
23.            brr(hS, j) = Arr(i, j)
    
24.          Next
    
25.        End If
    
26.     Next
    
27.     Sheet3.[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
28.    
    
29. MsgBox "用时" & Format((Timer - t), "#0.00") & "秒"
    
30. Application.ScreenUpdating = True
    
31. End Sub

复制代码

gwjkkkkk

在原代码上简单修改一下。。。

小凡、、、

看代码的意思，sheet1里c列不存在sheet2b列里 放到sheet3的意思

quqiyuan

其实差不多了，修改一下。。。

longwin

原代码稍作改动：
'把表1第3列和表2第2列相同瓶号的行复制到表3中
Sub test2() '字典+数组
Dim d, arr, brr, crr, i&, s, j&
Application.ScreenUpdating = False
t = Timer
Set d = CreateObject("scripting.dictionary")
    r = Sheet2.Cells(Rows.Count, 1).End(3).Row
    arr = Sheet2.[a1].Resize(r, 2)
   
    For i = 2 To UBound(arr)
        s = CStr(arr(i, 2))
        If Not d.exists(s) Then
            d(s) = i
        End If
    Next
   
    r = Sheet1.Cells(Rows.Count, 1).End(3).Row
    brr = Sheet1.[a1].Resize(r, 12)
    ReDim crr(1 To r, 1 To 12)
    For i = 2 To UBound(brr)
        s = CStr(Sheet1.Cells(i, 3))
        If d.exists(s) Then
        q = q + 1
         For j = 1 To 12
           crr(q, j) = brr(i, j)
         Next
       End If
    Next
    Sheet3.[a1].Resize(q, 12) = crr
   
MsgBox "用时" & Format((Timer - t), "#0.00") & "秒"
Application.ScreenUpdating = True
End Sub

longwin

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.31
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet2")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         c = .UsedRange.Columns.Count
   
6.         arr = .[a1].Resize(r, c)
   
7.     End With
   
8.     For i = 2 To UBound(arr)
   
9.         s = CStr(arr(i, 2))
   
10.         d(s) = ""
    
11.     Next
    
12.     With Sheets("Sheet1")
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         c = .UsedRange.Columns.Count
    
15.         arr = .[a1].Resize(r, c)
    
16.     End With
    
17.     ReDim brr(1 To r, 1 To 100)
    
18.     For i = 2 To UBound(arr)
    
19.         s = CStr(arr(i, 3))
    
20.         If d.exists(s) Then
    
21.             m = m + 1
    
22.             For j = 1 To 3
    
23.                 brr(m, j) = arr(i, j)
    
24.             Next
    
25.             For j = 4 To UBound(arr, 2)
    
26.                 brr(m, j + 1) = arr(i, j)
    
27.             Next
    
28.         End If
    
29.     Next
    
30.     With Sheets("Sheet3")
    
31.         .UsedRange.Offset(1) = ""
    
32.         .[a2].Resize(m, 12) = brr
    
33.     End With
    
34.     Set d = Nothing
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码