Excel求助批量导入固定模板实现批量打印（分页打印）的方法

熊文来 · 发表于 2019-10-21 11:10

朱荣兴发表于 2017-7-19 11:44

这么少的代码就完成问题了，真厉害可惜看不懂

sunman001 · 发表于 2021-6-30 10:23

本帖最后由 sunman001 于 2021-6-30 10:25 编辑

鄂龙蒙发表于 2017-7-19 12:52

老师好，我这里有一个类似的打印问题，但是我的数据表数据存在分组和分级关系，麻烦您帮我看一下，能不能在模板中实现分级分组打印

chxw68 · 发表于 2021-6-30 11:08

sunman001 发表于 2021-6-30 10:23
老师好，我这里有一个类似的打印问题，但是我的数据表数据存在分组和分级关系，麻烦您帮我看一下，能不能 ...

你举的例子是1.6的，1.1、1.2、1.3、1.4、1.5的打印吗？1.9的下面共有两级怎么打印？

sunman001 · 发表于 2021-6-30 11:29

本帖最后由 sunman001 于 2021-6-30 15:36 编辑

chxw68 发表于 2021-6-30 11:08
你举的例子是1.6的，1.1、1.2、1.3、1.4、1.5的打印吗？1.9的下面共有两级怎么打印？

谢谢老师关心，1.1 1.2 1.3 ……都要打印，均打印底层两级。我又检查了一下我的附件，对自己失误进行了修改。麻烦老师了

sunman001 · 发表于 2021-7-2 09:53

chxw68 发表于 2021-6-30 11:08
你举的例子是1.6的，1.1、1.2、1.3、1.4、1.5的打印吗？1.9的下面共有两级怎么打印？

老师好，我这个文档有救吗

？

chxw68 · 发表于 2021-7-2 10:59

Sub tqsj()
Dim r%, i%
Dim arr, brr
Dim lk(1 To 4) As Double
Dim rng As Range
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("单项工程费用数据表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:d" & r)
End With
For i = 1 To UBound(arr) - 1
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
d(arr(i, 1))(i) = Empty
For j = i + 1 To UBound(arr)
If arr(j, 1) Like arr(i, 1) & ".*" Then
Exit For
End If
Next
If j > UBound(arr) Then
If InStr(arr(i, 1), ".") <> 0 Then
xm = Left(arr(i, 1), InStrRev(arr(i, 1), ".") - 1)
If Not d.exists(xm) Then
Set d(xm) = CreateObject("scripting.dictionary")
End If
d(xm)(i) = Empty
End If
End If
Next
kk = d.keys
For k = 0 To UBound(kk)
aa = kk(k)
If d(aa).Count = 1 Then
d.Remove (aa)
End If
Next
For Each aa In d.keys
Debug.Print aa, d(aa).Count
ReDim brr(1 To d(aa).Count, 1 To 4)
m = 0
For Each bb In d(aa).keys
m = m + 1
brr(m, 1) = m
brr(m, 2) = arr(bb, 2)
brr(m, 3) = arr(bb, 3)
Next
d(aa) = brr
Next
With Worksheets("结果")
.Cells.Clear
.DisplayPageBreaks = False
End With
m = 1
With Worksheets("结算打印模板")
.Cells.PageBreak = xlPageBreakNone
For j = 1 To UBound(lk)
lk(j) = .Columns(j).ColumnWidth
Next
For Each aa In d.keys
brr = d(aa)
Set rng = .Columns("a:b").Find(what:="结算总价（小写）", LookIn:=xlValues, lookat:=1, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "结算打印模板有错误！"
Exit Sub
End If
.Rows("4:" & rng.Row - 1).Delete
.Rows(4).Resize(UBound(brr)).Insert
.Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
.Range("a1:d" & 3 + UBound(brr) + 7).Copy Worksheets("结果").Cells(m, 1)
.Cells(3 + UBound(brr) + 1, 3).Value = brr(1, 3)
With Worksheets("结果")
.Rows(m).RowHeight = 31.83
.Rows(m + 1).Resize(2 + UBound(brr) + 2 + 1).RowHeight = 20
.Rows(m + 2 + UBound(brr) + 3 + 1).Resize(4).RowHeight = 30
m = m + 3 + UBound(brr) + 7 + 1
.HPageBreaks.Add Before:=.Rows(m)
End With
Next
End With
With Worksheets("结果")
For j = 1 To UBound(lk)
.Columns(j).ColumnWidth = lk(j)
Next
End With
End Sub

复制代码

chxw68 · 发表于 2021-7-2 11:01

问题比较复杂，代码仅供参考。

sunman001 · 发表于 2021-7-2 11:41

chxw68 发表于 2021-7-2 10:59

哦，谢谢老师，辛苦了

sunman001 · 发表于 2021-7-2 11:43

chxw68 发表于 2021-7-2 11:01
问题比较复杂，代码仅供参考。

嗯嗯，好的，我觉得没有比这样更好的了，谢谢老师

sunman001 · 发表于 2021-7-2 12:05

chxw68 发表于 2021-7-2 11:01
问题比较复杂，代码仅供参考。

老师，对我来说公式太复杂了，以至于自己没办法理解修改，只能慢慢消化了。在“结算总价（小写）”对应的数据栏可以自模板提取到求和公式吗？提取对应底层两级，但是这两个层级中，较高一级的只要提取一个标题就可以了，“结算书”设为固定的尾部文本，辛苦老师再修改一下，万分感谢！！！

		自动登录	找回密码
密码			免费注册

[求助] Excel求助批量导入固定模板实现批量打印（分页打印）的方法

评分

评分

评分