按模板创建工作簿

zrf200788

求助 按模板创建工作簿，主要是为了批量打印。难点是 如何使创建的工作簿自动默认为A4，横向。同时单元格根据其内容自动调整行高，与 列宽。显示全面   

3190496160

我觉得目前的思路就是有问题的，
送货单做的多了，一般的思路：
1、用一个模板，模板先设定行高，确认这个行高一张A4纸张能打印几行，
2、每个送货单就按这几行来设定，同一个收货方的数据如果超过这个行数，就放到一下张送货单中，
3、所有的送货单全部生成到一个工作表内即可

wang-way

二楼言之有理。用VBA去设置格式就有点浪费时间了。

3190496160

Sub 生成送货单()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim rn As Range
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "汇总表为空！": End
    ar = .Range("a1:i" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> Empty Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
Set rn = Sheets("模板").Rows("1:41")
With Sheets("送货单")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    .Rows("42:" & rs).Delete
    m = 1
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To 8)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 1)) = k Then
                n = n + 1
                For j = 2 To UBound(ar, 2)
                    br(n, j - 1) = ar(i, j)
                Next j
            End If
        Next i
        If n <= 37 Then
            rn.Copy .Cells(m, 1)
            .Cells(m + 1, 3) = Left(k, 6)
            .Cells(m + 4, 1).Resize(n, UBound(br, 2)) = br
            m = m + 41
        Else
            For i = 1 To n Step 37
                rn.Copy .Cells(m, 1)
                .Cells(m + 1, 3) = Left(k, 6)
                xh = m + 3
                For s = i To i + 36 Step 1
                    If s <= n Then
                        xh = xh + 1
                        .Cells(xh, 1).Resize(1, UBound(br, 2)) = Application.Index(br, s, 0)
                    End If
                Next s
                m = m + 41
            Next i
        End If
    Next k
End With
Application.ScreenUpdating = True
MsgBox "送货单生成完毕！", 64, "提醒"
End Sub

3190496160

按2楼的思路写的，供参考
按模板创建出库单.rar (32.21 KB, 下载次数: 16)

2024-1-14 09:45 上传

点击文件名下载附件

zrf200788

3190496160 发表于 2024-1-14 09:45
按2楼的思路写的，供参考

感谢老师帮助

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.14
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("模板")
   
8.     With ThisWorkbook.Sheets("汇总表")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         arr = .Range("a1:i" & r)
    
11.     End With
    
12.     For i = 2 To UBound(arr)
    
13.         s = arr(i, 1)
    
14.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
15.         d(s)(i) = i
    
16.     Next
    
17.     For Each k In d.keys
    
18.         sh.Copy
    
19.         Set wb = ActiveWorkbook
    
20.         m = 0
    
21.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2) - 1)
    
22.         With wb.Sheets(1)
    
23.             .Name = k
    
24.             .[c2] = k
    
25.             fn = Left(k, 6)
    
26.             For Each kk In d(k).keys
    
27.                 m = m + 1
    
28.                 For j = 2 To UBound(arr, 2)
    
29.                     brr(m, j - 1) = arr(kk, j)
    
30.                 Next
    
31.             Next
    
32.             With .[a5].Resize(m, 8)
    
33.                 .Value = brr
    
34.                 .Borders.LineStyle = 1
    
35.                 .HorizontalAlignment = xlCenter
    
36.                 .VerticalAlignment = xlCenter
    
37.             End With
    
38.         End With
    
39.         wb.SaveAs p & fn
    
40.         wb.Close 1
    
41.     Next
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

ykcbf1100

附件供参考。。。