VBA批量插入图片

       一大早又有人妄想Sir做善事了，做好事不是不可以，话至少要说得好听。要人家做好事，话还说得不好听，不善做人做事，Sir理你才是傻。

        需求：衣服的不同型号在工作表里逐行排列，衣服图片放在以其相应型号命名的文件夹中，通过VBA批量插入到同一行，每个型号的衣服图片数量不定，自左向右同行排列。

        工作簿和文件夹存放如下：

        

        

具体代码如下：

实现效果：

Public Sub InsertPictures()

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    

    Dim Wb As Workbook, Sht As Worksheet

    Dim Rng As Range

    Const HEAD_ROW As Long = 1 '标题行数

    Const START_COLUMN As Long = 3 '无关列数

    Dim EndRow As Long

    Dim FolderPath As String, FileName As String

    Dim FilePath As String

    Dim Shp As Shape

    Dim iRow As Long, iCol As Long

    Dim StartTime, UsedTime As Variant

    StartTime = VBA.Timer '保存开始时间

    Set Wb = Application.ThisWorkbook '设置工作簿

    Set Sht = Wb.Worksheets('Sheet1') '设置工作表

    

    For Each Shp In Sht.Shapes

        Shp.Delete '预先清除所有图形

    Next Shp

    

    With Sht

        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row

        

        For iRow = HEAD_ROW 1 To EndRow '循环每个编号

        

            iCol = START_COLUMN '起始列

            FolderPath = Wb.Path & '\' & .Cells(iRow, 1).Text & '\' '文件夹路径

            

            FileName = Dir(FolderPath & '*.jpg*') '开始遍历文件夹

            Do While FileName <> ''

               FilePath = FolderPath & FileName '文件路径

               iCol = iCol 1 '调整列号

               Set Rng = .Cells(iRow, iCol) '输出单元格

               Set Shp = .Shapes.AddPicture(FilePath, msoFalse, msoCTrue, _

                                                   Rng.Left, Rng.Top, Rng.Width, Rng.Height) '插入图片

                FileName = Dir '下一个文件

            Loop

        Next iRow

        

    End With

    

    UsedTime = VBA.Timer - StartTime

    Debug.Print '本次耗时：' & Format(UsedTime, '0.000秒')

    

    Set Wb = Nothing

    Set Sht = Nothing

    Set Shp = Nothing

    Set Rng = Nothing

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub