Excel批量插图小工具

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