Excel批量插圖小工具

問題描述：根據商品貨號在Excel裏進行圖片展示
多文件批量插圖
本程序下載地址：https://download.csdn.net/download/qq_35866846/12170343
有下載使用不清楚的可以後臺留言
插入後效果圖：

執行界面：

Sub 批量插圖()
    Dim MyFileName, MyPath As String
    Dim MyBook As Workbook
    Dim count As Integer
    Dim pw As String
    
    Dim address As String
    Dim c As Range

    Dim cellcolumn, piccolumn As Integer
    
    On Error Resume Next '容錯處理
    
    address = Cells(1, 2).Value  '圖片文件夾所在的位置，根據圖片位置修改

    cellcolumn = Cells(2, 2).Value '設置款號所在列，根據自己實際情況修改
    
    piccolumn = Cells(3, 2).Value '設置插入圖片所在第幾列，根據自己實際情況修改

    count = 0
    
    MyPath0 = Cells(4, 2).Value
    
    For Each c In Range("b5：b7"):  '循環讀取子文件夾的文件夾名稱
        MyPath = MyPath0 & "\" & c.Value  '拼接文件所在路徑
        MyFileName = Dir(MyPath & "\*.xlsx")'索引查找子文件夾下的xlsx文件
        Application.ScreenUpdating = False'關閉屏幕更新，提升速度
        Application.DisplayAlerts = False
        Do Until MyFileName = ""
            Workbooks.Open MyPath & "\" & MyFileName'打開文件循環讀取文件
            Set MyBook = ActiveWorkbook
            
            For Each sht In MyBook.Sheets
                sht.DrawingObjects.Delete'循環sheet刪除原先表內插入的圖片
            Next
            

            For j = 2 To MyBook.Worksheets.count   '循環sheet寫入

                MyBook.Worksheets(j).Activate

                For I = 2 To Range("A65536").End(xlUp).Row  '數字2是設置開始填充圖片的行號是第二行，根據實際情況修改

                    Cells(I, piccolumn).Select
                  
                    ActiveSheet.Shapes.AddShape(msoShapeRectangle, (Cells(I, piccolumn).Left + 2.5), (Cells(I, piccolumn).Top + 2), (Cells(I, piccolumn).Width - 5), (Cells(I, piccolumn).Height - 4)).Fill.UserPicture address & "\" & Cells(I, cellcolumn).Text & ".jpg" '填充圖片 '圖片格式必須爲*.jpg格式，如果爲其他格式，在這裏更改圖片格式

                    Selection.ShapeRange.LockAspectRatio = msoTrue'固定圖片長寬比例不受影響
        
                    Selection.ShapeRange.Rotation = 0#  '設置圖片旋轉0度，即禁止圖片旋轉
        
                    Selection.Placement = xlMoveAndSize '圖片的大小和位置隨單元格的變化而變化
        
                    Selection.PrintObject = True

                Next I

            Next j
            MyBook.Save  '保存工作簿
            MyBook.Close True'關閉工作簿
            MyFileName = Dir '循環讀取下一個文件
            count = count + 1 '計數
         Loop
            Application.ScreenUpdating = True '還原屏幕更新設置
            Application.DisplayAlerts = True
    Next
    MsgBox (count & " 個文件全部插圖完成") '插圖完成，打印提示
End Sub