如何用VBA实现一对多、多对多的扩充表格内容

星梦月缘

    老师好，表1 是一对多的关系，表二是 表1里面的多  再扩展对应多的关系，最后想整合出表三的，也就是对标1种的多箱进项展开，描述有点复杂，看下面的图片示例就很清晰了。

我现在用PQ中的合并查询可以很快生成表3的样式，想问下 如果用VBA做的话，要如何快速生成表3 呢？   谢谢老师解答！

附件已上传。

沈默00

参与一下....

x-xx-xx

一二 二一

半百

沈默00

baofa2

1. Option Explicit
   
2. 
   
3. Sub test0()
   
4.   Dim Conn As Object, rs As Object
   
5.   Dim strConn As String, strSQL As String, i As Long
   
6.   Set Conn = CreateObject("ADODB.Connection")
   
7.   Set rs = CreateObject("ADODB.Recordset")
   
8.   If Application.Version < 12 Then
   
9.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
   
10.   Else
    
11.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
12.   End If
    
13.   Conn.Open strConn & ThisWorkbook.FullName
    
14.   strSQL = "SELECT a.订单信息表,b.套餐内容,b.包含商品,b.数量 FROM [$B3:C9] a LEFT JOIN [$G3:I15] b ON a.套餐内容=b.套餐内容  ORDER BY b.套餐内容,a.订单信息表,b.包含商品"
    
15.   rs.Open strSQL, Conn, 1, 3
    
16.   With Range("R3")
    
17.     .CurrentRegion.ClearContents
    
18.     For i = 0 To rs.Fields.Count - 1
    
19.       .Offset(0, i) = rs.Fields(i).Name
    
20.     Next
    
21.     .Offset(1).CopyFromRecordset rs
    
22.   End With
    
23.   rs.Close
    
24.   Set rs = Nothing
    
25.   Conn.Close
    
26.   Set Conn = Nothing
    
27.   Beep
    
28. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, vResult, i&, j&, r&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [B3].CurrentRegion.Value
    br = [G3].CurrentRegion.Value
    ReDim vResult(1 To UBound(ar) & UBound(br), 1 To 4)
   
    For i = 2 To UBound(br)
        dic(br(i, 1)) = dic(br(i, 1)) & " " & i
    Next i
   
    For i = 2 To UBound(ar)
        If dic.exists(ar(i, 2)) Then
             cr = Split(dic(ar(i, 2)))
             For j = 1 To UBound(cr)
                 r = r + 1
                 vResult(r, 1) = ar(i, 1): vResult(r, 2) = ar(i, 2)
                 vResult(r, 3) = br(cr(j), 2): vResult(r, 4) = br(cr(j), 3)
             Next j
        End If
    Next i
    [R4].Resize(r, 4) = vResult
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

wang-way

1. //wang-way 2024-05-18
   
2. function combine(){
   
3.         var sht=ThisWorkbook.Worksheets.Item(1);
   
4.         var d1={},d2={},d3={};
   
5.         var ar1=sht.Range('b3').CurrentRegion.Value();
   
6.         ar1.slice(1).forEach(r=>{
   
7.                 d1[r[0]]??=[];
   
8.                 d1[r[0]].push(r[1]);
   
9.         });
   
10.         var ar2=sht.Range('g3').CurrentRegion.Value();
    
11.         ar2.slice(1).forEach(r=>{
    
12.                 d2[r[0]]??=[];
    
13.                 d2[r[0]].push([r[1],r[2]]);
    
14.         });
    
15.        
    
16.         var br=[];
    
17.         for(let k1 in d1)//循环订单
    
18.         {
    
19.                 v1=d1[k1];//订单对应的套餐
    
20.                 for(let k2 of v1)//循环套餐
    
21.                 {
    
22.                         v2=d2[k2];//套餐包含的商品
    
23.                         for(let k3 of v2)//循环商品及数量
    
24.                         {
    
25.                                 br.push([k1,k2,...k3]);
    
26.                         }
    
27.                 }
    
28.         }
    
29. 
    
30.         br.forEach(r=>Debug.Print(...r));        //测试输出
    
31.         br.unshift(['订单信息表','套餐内容','包含商品','数量'])//添加表头
    
32.         sht.Range('S3').Resize(br.length,br[0].length).Value2=br;
    
33. }

复制代码