两表数据采集

卢嘉轩

两表数据采集.zip (15.44 KB, 下载次数: 18)

2021-8-12 20:47 上传

点击文件名下载附件

两表数据采集完成第三表。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("订单所需组件")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:b" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       d(arr(i, 1))(arr(i, 2)) = Empty
    
14.     Next
    
15.   End With
    
16.   With Worksheets("订单")
    
17.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     arr = .Range("a2:c" & r)
    
19.   End With
    
20.   ReDim brr(1 To 1000, 1 To 3)
    
21.   m = 0
    
22.   For i = 1 To UBound(arr)
    
23.     m = m + 1
    
24.     For j = 1 To UBound(arr, 2)
    
25.       brr(m, j) = arr(i, j)
    
26.     Next
    
27.     If d.exists(arr(i, 1)) Then
    
28.       For Each bb In d(arr(i, 1)).keys
    
29.         m = m + 1
    
30.         brr(m, 1) = arr(i, 1)
    
31.         brr(m, 2) = bb
    
32.         brr(m, 3) = arr(i, 3)
    
33.       Next
    
34.     End If
    
35.   Next
    
36.   With Worksheets("想要得到的结果")
    
37.     .UsedRange.Offset(1, 0).Clear
    
38.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

详见附件。

卢嘉轩

chxw68 发表于 2021-8-12 21:58
详见附件。

两表数据采集.zip (21.75 KB, 下载次数: 5)

2021-8-14 21:00 上传

点击文件名下载附件

老师：添加两列，如何达到？

chxw68

详见附件。

卢嘉轩

chxw68 发表于 2021-8-14 21:16
详见附件。

两表数据采集.zip (19.52 KB, 下载次数: 5)

2021-8-15 17:54 上传

点击文件名下载附件

老师：这样的效果能达到吗？

chxw68

修改好了。

卢嘉轩

chxw68 发表于 2021-8-16 10:05
修改好了。

两表数据采集 (3).zip (22.33 KB, 下载次数: 2)

2021-8-20 19:49 上传

点击文件名下载附件

老师：
再看看，运行后数据有不需要的。

chxw68

修改好了。

王跃峰

chxw68 发表于 2021-8-20 20:09
修改好了。

老师您好， sub  a 干什么用