如何从一个工作簿里的工作表数据按模板分配到多个工作簿或工作表里？

逆天修炼

各位路过的大神，如题，”03导出所有对帐单“是数据源表，”04送货单(模板)“是目标表格，要求按03表里的数据，以第2列的”日期“作为分发依据，相同的日期分发到04表中，04表里是一式3份表格，不同的日期分发到不同的04表里，想寻求两种方式解决上述数据分发的问题：
1、以04表作为模板，按日期生成多份工作簿
2、以04表里的”送货单“作为模板，按日期生成多份工作表
要求宏代码写在03工作簿里。

请大神指教，谢谢！

gwjkkkkk

模板共8列，同一日期超过8项怎么办？？？

逆天修炼

gwjkkkkk 发表于 2024-4-3 21:50
模板共8列，同一日期超过8项怎么办？？？

同一日期超过8列，需要本工作表中拷贝生成第二页

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, dr, i&, j&, r&, k&, dic As Object, vKey
    Dim strFileName$, strPath$, wks As Worksheet, iPosRow&
   

    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "04送货单(模板).xlsm"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    br = [M1:T2].Value
    dr = [{"B2",1;"B3",2;"F2",3;"F3",4;"H2",5;"H3",6;"D15",7;"I15",8}]
    For j = 1 To UBound(br, 2)
        If j = 1 Or j = 2 Then br(2, j) = br(1, j) & br(2, j)
        dr(j, 2) = br(2, j)
    Next j
   
    r = Cells(Rows.Count, "B").End(xlUp).Row
    ar = Range("A1:I" & r).Value
    For i = 3 To UBound(ar)
        dic(ar(i, 2)) = dic(ar(i, 2)) & " " & i
    Next i
   
    With GetObject(strFileName)
        Set wks = .Worksheets(1)
        With Workbooks.Add
            For Each vKey In dic.keys
                cr = Split(dic(vKey))
                ReDim br(1 To UBound(cr), 1 To 8)
                For i = 1 To UBound(cr)
                    For j = 2 To UBound(br, 2)
                        br(i, j) = ar(cr(i), j + 1)
                    Next j
                    br(i, 1) = ar(cr(i), 1)
                Next i
                br = cutArray(br, 8)
                For i = 1 To UBound(br)
                    wks.Copy after:=.Worksheets(.Worksheets.Count)
                    With ActiveSheet
                        .Name = vKey & "-" & i
                        For j = 1 To 3
                            iPosRow = IIf(j = 1, 1, (j - 1) * 17)
                            With .Cells(iPosRow, 1)
                                For k = 1 To UBound(dr)
                                    .Range(dr(k, 1)) = dr(k, 2)
                                Next k
                                .Cells(5, 2).Resize(UBound(br(i)), UBound(br(i), 2)) = br(i)
                            End With
                           
                        Next j
                    End With
                Next i
            Next
            For Each wks In .Worksheets
                If wks.Name Like "*Sheet*" Then wks.Delete
            Next
        End With
        .Close False
    End With
    Call CreateList
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
   
End Sub
Function cutArray(ByVal ar, iCutNum&) As Variant
    Dim br(), cr, i&, j&, iPosRow&, r&, k&
    For i = 1 To UBound(ar) Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > UBound(ar), UBound(ar) Mod iCutNum, iCutNum)
        ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
        For j = 1 To UBound(cr)
            For k = 1 To UBound(cr, 2)
                cr(j, k) = ar(i - 1 + j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = cr
    Next i
    cutArray = br
End Function
Function CreateList()
    Dim i&
   
    Worksheets.Add(before:=Worksheets(1)).Name = "工作表目录"
    [A1].Resize(, 2) = [{"序号", "日期"}]
    For i = 2 To Worksheets.Count
        Cells(i, 1).Value = i - 1
        ActiveSheet.Hyperlinks.Add Cells(i, 2), "", "'" & Worksheets(i).Name & "'" & "!B1", _
        "单击打开：" & Worksheets(i).Name, Worksheets(i).Name
        
        Worksheets(i).Hyperlinks.Add Worksheets(i).Cells(1, 2), "", _
        Worksheets(1).Name & "!B" & i, "返回目录"
        
    Next i
    Columns("A:B").AutoFit
End Function

gwjkkkkk

请参考附件。。。

ykcbf1100

比较复杂，先做一个拆分为多工作簿吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.4
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     With ws.Sheets("对帐单")
   
8.         r = .Cells(Rows.Count, 2).End(3).Row
   
9.         arr = .[a1].Resize(r, 9)
   
10.         br = .[m2:t2]
    
11.     End With
    
12.     ar = [{"A","B","C","D","E","F","G","H"}]
    
13.     p = ThisWorkbook.Path & ""
    
14.     p1 = p & "另存"
    
15.     If Dir(p1, vbDirectory) = "" Then MkDir p1
    
16.     f = p & "04送货单(模板).xlsm"
    
17.     Set wb = Workbooks.Open(f, 0)
    
18.     Set sh = wb.Sheets("送货单")
    
19.     b = [{1,3,4,5,6,7,8,9}]
    
20.     bb = [{5,21,38}]
    
21.     For i = 3 To UBound(arr)
    
22.         s = arr(i, 2)
    
23.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
24.         d(s)(i) = i
    
25.     Next
    
26.     On Error Resume Next
    
27.     For Each k In d.keys
    
28.         m = 0
    
29.         ReDim brr(1 To d(k).Count, 1 To 8)
    
30.         For Each kk In d(k).keys
    
31.             m = m + 1
    
32.             brr(m, 1) = m
    
33.             For j = 2 To UBound(b)
    
34.                 brr(m, j) = arr(kk, b(j))
    
35.             Next
    
36.         Next
    
37.         For i = 1 To m Step 8
    
38.             y = y + 1
    
39.             ReDim zrr(1 To 8, 1 To 8)
    
40.             For n = 1 To 8
    
41.                 For j = 1 To 8
    
42.                     zrr(n, j) = brr(i + (n - 1), j)
    
43.                 Next
    
44.             Next
    
45.             If m <= 8 Then
    
46.                 sh.Copy
    
47.                 Set wb1 = ActiveWorkbook
    
48.                 Set sht = wb1.Sheets(1)
    
49.             Else
    
50.                 sh.Copy after:=wb1.Sheets(wb1.Sheets.Count)
    
51.                 Set sht = ActiveSheet
    
52.             End If
    
53.             With sht
    
54.                 .Name = "送货单" & IIf(m <= 8, "", "（" & y & ")")
    
55. '                For r = 1 To UBound(ar)
    
56. '                    .Range(ar(r)) = Replace(.Range(ar(r)),br(r)
    
57. '                Next
    
58.                 For x = 1 To 3
    
59.                     .Cells(bb(x), 2).Resize(8, 8) = zrr
    
60.                 Next
    
61.             End With
    
62.         Next i
    
63.         wb1.SaveAs p1 & "送货单" & Replace(k, ".", "-")
    
64.         wb1.Close
    
65.     Next
    
66.     wb.Close 0
    
67.     Application.ScreenUpdating = False
    
68.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
69. End Sub
    
70. 
    

复制代码

逆天修炼

首先感谢gwjkkkkk和ykcbf1100两位大佬的帮忙，辛苦了！！
我先认真读一下代码，有不懂的地方再跟两位请教！

逆天修炼

gwjkkkkk 发表于 2024-4-4 12:28
Option Explicit
Sub TEST1()
    Dim ar, br, cr, dr, i&, j&, r&, k&, dic As Object, vKey

gwjkkkkk老师，你的代码我看了，只是还有几个问题需要更正：
1、“送货单”上的送货日期需要根据“建材对账单”第2列的日期进行对应输入。
2、每份“送货单”的序号列不能取“建材对账单”上的序号，需要重新按1.2.3....输入
3、每份“送货单”上的小写金额，可以在模板中设置sum公式，但是需相应的在“合计金额(大写):”后面输入大写金额。
4、可否为““送货单””上需要填入内容的单元格，指定单独设置字体？

可否麻烦gwjkkkkk老师再修改一下？

gwjkkkkk

1.日期已改.
2.序号同一天二张单子是连续的，一张则重新编号
3.已汇总小写金额，大写金额直接用自定义函数完成。
4.单独设置字体，可在模板上预先设置好。