求助老师帮忙写段代码实现图片批量插入到指定单元格内

Dong2116

由于此表每天需要报送，需要批量插入图片并放到指定单元格位置 ，烦请老师帮忙写一段代码 实现一键插入放置图片到表格所在行列。万分感谢！

明天会更好zj

你得一并提供你的图片上来

Dong2116

明天会更好zj 发表于 2024-9-7 17:46
你得一并提供你的图片上来

老师 图片每天的数量都不一样，但是都会在这个文件夹内。

gwjkkkkk

///////////////

gwjkkkkk

Option Explicit
Sub test()
    Dim ar$(), i&, strFileName$, strPath$, c&, r&, n&, shp As Shape
   
    strPath = "E:\9月食材图片\"
    strFileName = Dir(strPath & "*.png")
    Do Until strFileName = ""
        n = n + 1
        If n > 15 Then Exit Do
        ReDim Preserve ar(1 To n)
        ar(n) = strPath & strFileName
        strFileName = Dir
    Loop
    If n = 0 Then Exit Sub
   
    Application.ScreenUpdating = False
   
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 11 Then shp.Delete
    Next
    With [G2:K6]
        For i = 1 To UBound(ar)
            r = (-Int(-(i / 5)) - 1) * 2 + 1
            c = IIf(i Mod 5 = 0, 5, i Mod 5)
            With .Cells(r, c)
                .Select
                ActiveSheet.Pictures.Insert(ar(i)).Select
                With Selection
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Height = ActiveCell.RowHeight ' * 5
                    .Width = ActiveCell.Width
                    .Placement = xlMoveAndSize
                End With
            End With
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim ar$(), i&, strFileName$, strPath$, c&, r&, n&, shp As Shape
   
    strPath = "E:\9月食材图片\"
    strFileName = Dir(strPath & "*.png")
    Do Until strFileName = ""
        n = n + 1
        If n > 15 Then Exit Do
        ReDim Preserve ar(1 To n)
        ar(n) = strPath & strFileName
        strFileName = Dir
    Loop
    If n = 0 Then Exit Sub
   
    Application.ScreenUpdating = False
   
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 11 Then shp.Delete
    Next
    With [G2:K6]
        For i = 1 To UBound(ar)
            r = (-Int(-(i / 5)) - 1) * 2 + 1
            c = IIf(i Mod 5 = 0, 5, i Mod 5)
            With .Cells(r, c)
                .Select
                ActiveSheet.Pictures.Insert(ar(i)).Select
                With Selection
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Height = ActiveCell.RowHeight ' * 5
                    .Width = ActiveCell.Width
                    .Placement = xlMoveAndSize
                End With
            End With
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

cai2532

插入图片实例学习了

GG函数

你可以永久免费使用我开发的插件 ，全部功能免费

过客fppt

给你推荐一个牛逼的图片处理插件，不过要收费49元，建议叫你老板给你买。因为公司要为员工提供一定的劳动条件
【快速批量插入文件夹内所有图片到一个单元格并排版-哔哩哔哩】 https://b23.tv/r7W3v2i