使用VBA图片批量多行多列排布

gateun

最好上下左右图片与图片留有空白间隔
Sub 自动生成图片()
'
' 自动生成图片 宏
'


'
Worksheets(1).Select
lj = Sheet1.Cells(2, 4) '相片路径
xqm = Sheet1.Cells(1, 4) '小区名称
hs = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("图片").Select
Set myDocument = Worksheets("图片")
Rows("1:50").RowHeight = 375
For l = 1 To 100 Step 2
Columns(l).ColumnWidth = 55
Columns(l + 1).ColumnWidth = 30
For h = 1 To 50
i = i + 1 '第一列的行数
If i > hs Then GoTo 100:
wj = Sheet1.Cells(i, 2) '获取图片名称
hk = 375 * (h - 1)
lK = 150 * Int(l / 2)
myDocument.Shapes.addpicture lj & wj & ".jpg", True, True, lK, hk, 375, 375


Cells(h, l + 1).Value = Sheet1.Cells(i, 1).Value




Next h
Next l
100:
bb = lj & Format(Now(), "mmddhhmmss") & xqm & ".xls"
Sheets("Sheet2").Select
    Sheets("Sheet2").Copy
    ActiveWorkbook.SaveAs Filename:= _
        bb, FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
        ActiveWorkbook.Close
ThisWorkbook.Close False '模块里关闭工作簿，且不保存。
End Sub


Option Explicit
Sub select_rows()
    Dim i As Long, j As Long
    Dim myrange As Range
    For i = 2 To Sheet2.Range("C1").Value * 2 Step 2
    For j = 1 To 8
    Set myrange = Range(Cells(2, j), Cells(6, j))
    Sheets("图片").Select
    ActiveSheet.Shapes.Range(Array("Picture " & i)).Select
    Selection.Copy
    Sheets("首末检一页纸").Select
    myrange.Select
    Selection.Value = 1
    ActiveSheet.Paste
    Next j
    Next i
End Sub


Sub 宏4()
'
' 宏4 宏
'
    Dim i As Long, j As Long, k As Long
    For k = 1 To 6
    For j = 1 To 8
    For i = 2 To Sheet2.Range("C1").Value * 2 Step 2
    Sheets("图片").Select
    ActiveSheet.Shapes.Range(Array("Picture " & i)).Select
    Selection.Copy
    Sheets("首末检一页纸").Select
    Cells(k, j).Select
    ActiveSheet.Paste
    Next i
    Next j
    Next k
End Sub


多次调试不行，请求大师帮助！

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=15791c27
楼主 看看这个链接是否有帮助吧

gateun

liulang0808 发表于 2023-4-4 08:02
https://club.excelhome.net/thread-1441877-1-1.html?_dsign=15791c27
楼主 看看这个链接是否有帮助吧

你这个我已运用到我上传的附件了，就是因它只是一个链接图片，换一台电脑打开，链接失效，图片没有转换成本地图片

liulang0808

gateun 发表于 2023-4-4 11:40
你这个我已运用到我上传的附件了，就是因它只是一个链接图片，换一台电脑打开，链接失效，图片没有转换成 ...

还有另外一种插入图片方式，链接里也有，可以测试看看

gateun

liulang0808 发表于 2023-4-4 14:10
还有另外一种插入图片方式，链接里也有，可以测试看看

链接上另一种没找到，直接上附近可以吗，谢谢！

liulang0808

看看这个是否可行吧

gateun

liulang0808 发表于 2023-4-4 16:54
看看这个是否可行吧

你的原附件可以，插图图片改了，你的图片不会变，我另存一份后，插图变了，自动刷新，是链接图片，excel文件大小只有30K，你的是本地图片148K

gateun

gateun 发表于 2023-4-4 20:08
你的原附件可以，插图图片改了，你的图片不会变，我另存一份后，插图变了，自动刷新，是链接图片，excel ...

worksheet.Shapes.AddPicture，非引用插入这个怎么用