按条件分页打印

荷塘小舍

VBA中的小白，套用修改就是不行，玩了好多天了，总是玩不出名堂，求教各路大神。
1、如何实现自动分页按供应商打印（供应商货品超过35行的按每页带表头35行打印，其余过到另一页
2、打印时按供应商自动添加表头（加粗）
如：甲5的表头为：yyyy年m月份  甲5   供货情况(其中：yyyy年m月 变动根据Sheet1 C列更好)
如：乙2的表头为：yyyy年m月份  乙2   供货情况

3、列宽要求
B列	4.83
C	11.83
D	11.83
E	17.5
F	4.33
G	4.33
H	5.67
I	8.5
J	16
K	11.83
L	11.83
M	5
N	5
O	6
P	8
供应商货品35行，行高20

荷塘小舍

乐乐2006201505 曾提供代码：可不知道代码如何修改
模块1
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("供应商票据")
    r = .Columns(5).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    arr = .Range("e1:e" & r)
    For i = 6 To UBound(arr)
      If Len(arr(i, 1)) <> 0 Then
        If Not d.exists(arr(i, 1)) Then
          Set d(arr(i, 1)) = .Range("a1:q4")
        End If
        Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 17))
      End If
    Next
  End With
  For Each aa In d.keys
    On Error Resume Next
    Set ws = Worksheets(aa)
    If Err Then
      Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
      ws.Name = aa
    End If
    On Error GoTo 0
    With Worksheets(aa)
      .Cells.Clear
      d(aa).Copy .Range("a1")
      .Range("f1") = aa & "2017年9月供货情况"
      .Range("b3:q4").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
      Call 宏1
'      With .PageSetup
'        .PrintTitleRows = "$1:$4"
'      End With
         ActiveWindow.SelectedSheets.PrintOut
         .Delete
    End With
  Next
   
End Sub
模块2
Sub 宏1()
'
' 宏1 宏
'

'
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Range("A3:A4").Select
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
    Range("A5:A44").Select
    Columns("C:C").ColumnWidth = 9.83
    Columns("E:E").ColumnWidth = 12
    Columns("E:E").ColumnWidth = 14.5
    Columns("D:D").ColumnWidth = 5.5
    Columns("G:G").ColumnWidth = 7.33
    Columns("G:G").ColumnWidth = 6.33
    Columns("F:F").ColumnWidth = 5.17
    Columns("J:J").ColumnWidth = 6.67
    Rows("5:89").Select
    Selection.RowHeight = 15
    Range("A5").Select
    Rows("5:89").Select
    Range("A89").Activate
    Selection.RowHeight = 19.5
    Rows("5:51").Select
    Range("A51").Activate
    Selection.RowHeight = 21
    Selection.RowHeight = 20.25
    Rows("2:2").RowHeight = 23.25
    Rows("2:2").RowHeight = 18
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$4"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 72
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    Rows("2:2").RowHeight = 34.5
    Rows("1:1").RowHeight = 32.25
    Selection.RowHeight = 23.25
    Range("B45:B84").Select
    Range("A5").Select
End Sub

荷塘小舍

也曾经找到一个类似的代码，就是不知道修改，望各位大神帮忙

Private Sub CommandButton1_Click()
Dim arr As Variant
Dim brr()
Dim i, s As Integer
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 4)) Then
Set d(arr(i, 4)) = Sheet1.Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(arr(i, 4)) = Union(d(arr(i, 4)), Sheet1.Range("a" & i).Resize(1, UBound(arr, 2)))
End If
Next i
x = d.keys
For i = 0 To UBound(x)
Sheets("按试场打印").[a1] = "第" & x(i) & "试场考生安排表"
Sheets("按试场打印").UsedRange.Offset(1).Clear
Sheet1.Rows(1).Copy Sheets("按试场打印").[a2]
d.items()(i).Copy Sheets("按试场打印").[a3]
Sheets("按试场打印").Rows("2:60").RowHeight = 22
  Sheets("按试场打印").PrintOut From:=1, To:=1, Copies:=1, Collate:=True
  Next i
End Sub





按钮
Sub 打印()
'
' 打印 Macro
' 宏由 FtpDown 录制，时间: 2017/5/31
'

'
    ActiveWindow.SelectedSheets.PrintPreview
    ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
End Sub
Sub 行高()
'
' 行高 Macro
' 宏由 FtpDown 录制，时间: 2017/5/31
'

'
    ActiveWindow.SmallScroll Down:=-3
    Rows("2:11").RowHeight = 17
End Sub

荷塘小舍

自己顶一下，希望大神们能看到

LMY123

根据D列拆分工作表，固定30行数据

荷塘小舍

LMY123 发表于 2017-11-3 08:31
根据D列拆分工作表，固定30行数据

不会弄啊，老师

LMY123

荷塘小舍 发表于 2017-11-3 13:17
不会弄啊，老师

Sub 生成()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        zu = arr(i, 4)
        If zu <> "" Then d(zu) = d(zu) & "-" & i
    Next
   
    Application.ScreenUpdating = False
    rmax = 30 '每张表最大人数
    For Each zu In d.keys
        xrr = Split(d(zu), "-")
        rs = UBound(xrr)    '组的人数
        n = (rs - 0.1) \ rmax + 1
        For pg = 1 To n
            Sheets(3).Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = zu & "-" & pg
                ReDim brr(1 To rmax, 1 To UBound(arr, 2))
                s = (pg - 1) * 30  '起始位置
                For r = 1 To rmax
                    If r + s <= rs Then
                        i = xrr(r + s)
'''                        For j = 1 To UBound(arr, 2)
                            brr(r, 1) = arr(i, 1)
                            brr(r, 2) = arr(i, 3)
                            brr(r, 3) = arr(i, 4)
                            brr(r, 4) = arr(i, 6)
                            brr(r, 5) = arr(i, 7)
                            brr(r, 6) = arr(i, 9)
                            brr(r, 7) = arr(i, 11)
'''                        Next
' For j = 3 To 4 'UBound(arr, 2)
'                            brr(r, j) = arr(i, j)
'                        Next
                    End If
                Next
                .[B6].Resize(rmax, UBound(brr, 2)) = brr
            End With
        Next
    Next
    Sheets(1).Activate
    Application.ScreenUpdating = True
End Sub

Sub 清除()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Index > 3 Then sh.Delete
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub 打印()
    For Each sh In Worksheets
        If sh.Index > 2 Then sh.PrintPreview
        'If sh.Index > 2 Then sh.PrintOut
    Next
End Sub

LMY123

荷塘小舍 发表于 2017-11-3 13:17
不会弄啊，老师

按条件分页打印.rar (376.44 KB, 下载次数: 95)

2017-11-3 15:11 上传

点击文件名下载附件

荷塘小舍

LMY123 发表于 2017-11-3 15:11

这种思路也挺好的，而且还可以清除。chxw68也用这种方法。可是因为供应商家数多用这种方法打印，还是比较麻烦的，还有Sheet1工作表经常要换，所以代码想做在“供应商票据”里，这张工作表还有比价数据要用到的。
所以希望老师能否用一键打印之类的方法，帮帮做个代码呢。

荷塘小舍

LMY123 发表于 2017-11-3 15:11

谢谢老师，按D列拆分打印（改成35行后的画线没了，不知道哪里改），这个思路挺好的，chxw68老师也这样想。只是Sheet1里的数据要经常更换，所以代码希望做在“供应商单据”“里面，还有因为供应商众多，用这种方法还是感觉比较麻烦。希望老师能否帮帮做一个一键打印之类的代码。谢谢！谢谢！！