一对多的数据提取汇总问题

mmwwdd

这种题用SQL比较方便，这是个笛卡尔积的问题

chxw68

1. Sub test1()
   
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.         brr = .Range("a2:c" & r)
   
9.         For i = 1 To UBound(brr)
   
10.             If Not d.exists(brr(i, 1)) Then
    
11.                 Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
    
12.             End If
    
13.             d(brr(i, 1))(i) = 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 crr(1 To UBound(arr) * UBound(brr), 1 To 6)
    
21.     m = 0
    
22.     For i = 1 To UBound(arr)
    
23.         If d.exists(arr(i, 2)) Then
    
24.             For Each bb In d(arr(i, 2)).keys
    
25.                 m = m + 1
    
26.                 For j = 1 To UBound(arr, 2)
    
27.                     crr(m, j) = arr(i, j)
    
28.                 Next
    
29.                 crr(m, 4) = brr(bb, 2)
    
30.                 crr(m, 5) = brr(bb, 3)
    
31.                 crr(m, 6) = crr(m, 3) * crr(m, 5)
    
32.             Next
    
33.         End If
    
34.     Next
    
35.         
    
36.     With Worksheets("结果")
    
37.         .UsedRange.Offset(1, 0).Clear
    
38.         .Range("a2").Resize(m, UBound(crr, 2)) = crr
    
39.     End With
    
40. End Sub
    

复制代码

chxw68

参与一下，一题两解。

grf1973

。。。。。。。。。。。。。。。。。

demonimissyou

Sub xx()
Dim i, j, arr, brr, crr, dic
Set dic = CreateObject("Scripting.dictionary")
arr = Sheets("订单").Range("a1:c" & Sheets("订单").[a65536].End(xlUp).Row)
brr = Sheets("款式").Range("a1:c" & Sheets("款式").[a65536].End(xlUp).Row)
ReDim crr(1 To UBound(arr) * UBound(brr), 1 To 6)
For i = 2 To UBound(arr)
For j = 2 To UBound(brr)
If arr(i, 2) = brr(j, 1) Then
l = l + 1
crr(l, 1) = arr(i, 1)
crr(l, 2) = arr(i, 2)
crr(l, 3) = arr(i, 3)
crr(l, 4) = brr(j, 2)
crr(l, 5) = brr(j, 3)
crr(l, 6) = crr(l, 3) * crr(l, 5)
End If
Next
Next
Sheets("结果").Cells(1, 1) = "备注": Sheets("结果").Cells(1, 2) = "款式": Sheets("结果").Cells(1, 3) = "份数": Sheets("结果").Cells(1, 4) = "商品代码": Sheets("结果").Cells(1, 5) = "数量": Sheets("结果").Cells(1, 6) = "汇总"
Sheets("结果").[A2].Resize(UBound(crr), 6) = crr
End Sub