Excel 批量打印 Vba 代码修改求助

18388319008

批量打印，图片只打印显示当前页面，不会随着序号滚动打印相应页面图片
请求帮助能正常批量打印

[Visual Basic] 纯文本查看 复制代码

Sub 
For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 10 Then 
        shp.Delete 
    End If
Next shp
xm = [b3] 
If IsError(xm) Then End 
lj = ThisWorkbook.Path & "\照片\" '''把照片所在路径赋值给变量lj
f = Dir(lj & "*.*g") 
sl = Len(Trim(xm)) 
Do While f <> "" 
    mc = ""
    If Left(f, sl) = xm Then 
        If InStr(f, "1") > 0 Then 
            lh = 1 
            ls = 3
            mc = 1
        ElseIf InStr(f, "2") > 0 Then
            lh = 4
            ls = 3
            mc = 2
        ElseIf InStr(f, "3") > 0 Then
            lh = 7
            ls = 4
            mc = 3
        End If
        If mc < 4 Then
            Cells(11, lh).Resize(1, ls).Select 
            cellL = ActiveCell.Left + 3 
            cellT = ActiveCell.Top 
            Set shpPic = ActiveSheet.Shapes.AddPicture(lj & f, msoFalse, msoTrue, cellL, cellT, 1, 1)
            shpPic.Top = Cells(11, lh).Resize(1, ls).Top + 1 
            shpPic.Left = Cells(11, lh).Resize(1, ls).Left + 1
            shpPic.Width = Cells(11, lh).Resize(1, ls).Width - 1
            shpPic.Height = Cells(11, lh).Resize(1, ls).Height - 1 
            Set shpPic = Nothing 
        End If
    End If
f = Dir
Loop
End Sub
Sub pldy()
Application.ScreenUpdating = False 
ks = [m6] 
js = [m7] 
If ks = "" Then MsgBox "请输入开始行号！": End ''如果为空，则强制结束代码运行
If js = "" Then MsgBox "请输入结束行号！": End ''如果为空，则强制结束代码运行
If ks > js Then MsgBox "开始行号必须小于等于结束行号！": End ''如果开始行大于结束行，则强制结束代码运行
w = MsgBox("您点击了批量打印，是否继续！", vbYesNo)
If w = vbNo Then End
For i = ks To js
    [l2] = i 
    ActiveSheet.PrintOut ''打印
Next i
Application.ScreenUpdating = True 
MsgBox "打印完毕" 
End Sub

示例地址   https://wwl.lanzoue.com/isxSI1uchjlg

sunnychen

[Visual Basic] 纯文本查看 复制代码

Sub pldy()
Application.ScreenUpdating = False ''禁止屏幕刷新，提高运行速度
ks = [m6] ''i5单元格的值复制给变量ks
js = [m7] ''i6单元格的值复制给变量js
If ks = "" Then MsgBox "请输入开始行号！": End ''如果为空，则强制结束代码运行
If js = "" Then MsgBox "请输入结束行号！": End ''如果为空，则强制结束代码运行
If ks > js Then MsgBox "开始行号必须小于等于结束行号！": End ''如果开始行大于结束行，则强制结束代码运行
w = MsgBox("您点击了批量打印，是否继续！", vbYesNo)
If w = vbNo Then End
For i = ks To js ''在设置的开始行和结束行之间循环
    [l2] = i ''行号写入i2单元格
    Call 插入照片
    ActiveSheet.PrintOut ''打印
Next i ''结束循环
Application.ScreenUpdating = True ''恢复屏幕刷新
MsgBox "打印完毕" '''提示框
End Sub

第12行增加：Call 插入照片