批量插入图片到单元格

Sub 批量插入图片到工作表()
    '-----------------------------------------------------------------------
    '自定义数据类型
    Dim ImgFileFormat, FirstAddress As String
    Dim Pic As Variant, Pic_name As String, Sizes As String, Choose_sht_name As String
    Dim Choose_rng, rng As Range
    Dim i As Integer
    Dim C As Range
    Dim Shp As Shape  '声明图形对象变量
    
    
    '选择需要插入区域
    On Error Resume Next
    Set Choose_rng = Application.InputBox("选择需要插入的单元格或单元格区域", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    If WorksheetFunction.CountA(Choose_rng) = 0 Then MsgBox "选择单元格区域为空": Exit Sub
    Choose_sht_name = Choose_rng.Parent.Name
    On Error GoTo 0
    
    '选择需要插入的图片及自定义图片的高度与宽度
    ImgFileFormat = "Image files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg;*.png)," & "*.bmp;*.gif;*.tif;*.jpg;*.jpeg;*.png" '指定图片格式
    Pic = Application.GetOpenFilename(ImgFileFormat, , "选择多张图片", , True) '打开一个图片选择对话框
    If VBA.TypeName(Pic) = "Boolean" Then
        MsgBox "没有选择文件": Exit Sub
    End If
    

Star:
    Sizes = Application.InputBox("请指定图片的高度与宽度，中间用半角逗号隔开" & Chr(10) & "例如“30,260”或者“80,100”", "指定图片大小", "100,120", , , , , 2)
    If InStr(Replace(Sizes, ", ", ","), ",") = 0 Then GoTo Star '如果没有输入","则返回重新输入
    
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
    
    For i = 1 To UBound(Pic)
        '获取图片名字
        Pic_name = StrReverse(Mid(StrReverse(Pic(i)), WorksheetFunction.Find(".", StrReverse(Pic(i))) + 1, WorksheetFunction.Find("\", StrReverse(Pic(i))) - 1 - WorksheetFunction.Find(".", StrReverse(Pic(i)))))
        
        '添加图片批注
        With Choose_rng
            Set C = .Find(Pic_name, LookIn:=xlValues)
            If Not C Is Nothing Then
                FirstAddress = C.Address
                Do
                    Sheets(Choose_sht_name).Activate
                    Sheets(Choose_sht_name).Pictures.Insert(Pic(i)).Select  '插入图片
                    
                    With Selection
                        .Left = C.Offset(0, 1).Left '使图片的左边距等于其左上单元格的左边距
                        .Top = C.Offset(0, 1).Top    '使图片的上边距等于其左上单元格的上边距
                        .Height = Split(Replace(Sizes, ", ", ","), ",")(1) '调整图片高度
                        .Width = Split(Replace(Sizes, ", ", ","), ",")(0)  '调整图片宽
                        
                        C.Offset(0, 1).RowHeight = .Height '调整行宽度
                        C.Offset(0, 1).ColumnWidth = .Width / 5.5 '调整列宽度,模糊调整
                       
                    End With
                    Set C = .FindNext(C)
                Loop While Not C Is Nothing And C.Address <> FirstAddress
            End If
        End With
    Next i
    
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox "插入图片完成"
End Sub
1：批量插入图片并适配单元格
2：自定义宽高
3：自主修改部分代码做成小的应用
源码视频演示
批量插入图片到单元格并适应宽高度

目录
