每页打印“5行”“可见”“单元格”（红包跪求，求助大神）

haugine

描述：黄色部分为打印区域。
B4,C4，会根据情况进行筛选。
1~4行的是标题行，每页打印。
想要实现的内容：
1.筛选后的“可见”单元格，打印出来。
2.B或者C列，第5行开始，每页打印5行“合并单元格”。
3.产品图，功能特性，状态，这3列会插入图片。
最终实现的目标是，合并单元格不被拆分开来。

如果准确点描述（就是，如果打印的时候，
有一个合并单元格，被分成前页一半，后页一半，
则：直接将整个单元格放到下页打印）

还希望能帮忙给份VBA，实现H：k列的3列的合并单元格内的图片自动居中。

haugine

跪求大师，跪求大师

haugine

怎么都没有人来帮忙下，在线等，急求。
发红包。

lsc900707

haugine 发表于 2017-10-16 15:37
怎么都没有人来帮忙下，在线等，急求。
发红包。

楼主的问题可能有点难度，处理也需要一些时间，请耐心等候。

haugine

lsc900707 发表于 2017-10-16 15:48
楼主的问题可能有点难度，处理也需要一些时间，请耐心等候。

好，只要能搞定，就可以。感激感激

wzsy2_mrf

能给多大的红包呢？现在叫民工搬砖都要几百一天。

haugine

wzsy2_mrf 发表于 2017-10-16 17:41
能给多大的红包呢？现在叫民工搬砖都要几百一天。

哦，您能搞定？

jiaxinl

haugine 发表于 2017-10-16 18:50
哦，您能搞定？

请问现在还有效吗？

haugine

jiaxinl 发表于 2017-10-17 16:45
请问现在还有效吗？

有效啊。

jiaxinl

haugine 发表于 2017-10-17 23:34
有效啊。

请查收附件及动态图，你看OK不？
关于你提到的第2点.B或者C列，第5行开始，每页打印5行“合并单元格”。
也会遇到合并单元格被拆分的时候。
还是采取如果打印的时候，有一个合并单元格，被分成前页一半，后页一半，移到下页打印

这样一来就不能每页保证5行“合并单元格”了


以下是代码
Sub 打印和调整图片()
  Dim dic, r%, i%, k%, j%, p%, rng As Range
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary") '建立字典dic
  r = Cells(Rows.Count, 2).End(xlUp).Row  'B列非空单元格的行号
  ActiveSheet.PageSetup.PrintArea = ""
  ActiveSheet.PageSetup.PrintTitleRows = ""
  ActiveSheet.PageSetup.PrintArea = "$C$5:$K$" & r '设置列印区域
  ActiveSheet.PageSetup.PrintTitleRows = "$1:$4" '设置列印标题
  ActiveSheet.ResetAllPageBreaks '重设分隔符
  For i = 5 To r - 8
    If i <= r - 8 Then
      If Range("L" & i).MergeCells Then
        dic(i) = k + 1  '合并单元格的行号装入字典
        i = Mid(Range("L" & i).MergeArea.Address, InStrRev(Range("L" & i).MergeArea.Address, "$") + 1) '合并单元格右下脚的行号
      End If
    End If
  Next i
Application.Goto Range("B" & r + 1), True '滚动条到B列非空单元格的下一行
j = ActiveSheet.HPageBreaks.Count '水平分隔符的数量
For p = 1 To j  '在所有的水平分隔符中循环
  Set rng = [C:C].Find(ActiveSheet.HPageBreaks(p).Location, LookAt:=xlWhole) '分隔符所在的位置
  If dic.Exists(rng.Row) Then ActiveSheet.HPageBreaks.Add Before:=Range("C" & rng.Row) '分隔符所在位置的合并单元格的行号在字段中存在时,添加分隔符
Next p
Application.Goto Range("B1"), True '滚动条到B1
Call 图片居中
MsgBox "OK!", 64, "提示"


Application.EnableEvents = False '禁止事件
If (MsgBox("打印前是否预览?", vbYesNo, "提示")) = vbNo Then
  On Error Resume Next
  ActiveWindow.SelectedSheets.PrintOut Copies:=1 '打印1份
Else
  ActiveSheet.PrintPreview '打印预览
End If
Application.EnableEvents = True '启用事件
End Sub


Sub 图片居中()
Dim Shp As Shape, ad$, r%, c%
  For Each Shp In Sheet6.Shapes
    If Shp.Type = msoPicture Then  '为图片时
      ad = Replace(Shp.BottomRightCell.Address, "$", "") '获取图片右下脚所在的单元格地址
      If Range(ad).MergeCells Then '为合并单元格时
        r = Range(ad).MergeArea.Row '合并单元格的行号
        c = Range(ad).MergeArea.Column '合并单元格的列号
      End If
      With Shp  '位置和大小
        .LockAspectRatio = msoFalse '取消纵横比
        .Placement = xlMoveAndSize  '大小和位置随单元格而变
        .Height = Cells(r, c).MergeArea.Height - 30 '高
        .Width = Cells(r, c).MergeArea.Width - 30   '宽
        .Left = Cells(r, c).MergeArea.Left + (Cells(r, c).MergeArea.Width - .Width) / 2 '左
        .Top = Cells(r, c).MergeArea.Top + (Cells(r, c).MergeArea.Height - .Height) / 2 '顶
      End With
    End If
  Next Shp
End Sub