江苏龙网

  1. 主页 > 生活百科 > >

Excel插入批量图片，套用这些代码就OK

以下文章来源于VBA编程学习与实践，作者EH看见星光
咱们今天分享的内容是按指定名称和位置批量将图片插入到Excel工作表中……
看个动画先：

Excel插入批量图片，套用这些代码就OK

文章插图
 
代码如下
Sub InsertPic()    'ExcelHome VBA编程学习与实践 by:看见星光    Dim Arr, i&, k&, n&, pd&    Dim strPicName$, strPicPath$, strFdPath$, shp As Shape    Dim Rng As Range, Cll As Range, Rg As Range, strWhere As String    'On Error Resume Next    '用户选择图片所在的文件夹    With Application.FileDialog(msoFileDialogFolderPicker)       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub    End With    If Right(strFdPath, 1) <> "" Then strFdPath = strFdPath & ""    Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)    '用户选择需要插入图片的名称所在单元格范围    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)    'intersect语句避免用户选择整列单元格，造成无谓运算的情况    If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub    strWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")    '用户输入图片相对单元格的偏移位置 。    If Len(strWhere) = 0 Then Exit Sub    x = Left(strWhere, 1)    '偏移的方向    If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位 。": Exit Sub    y = Val(Mid(strWhere, 2))    '偏移的值    Select Case x        Case "上"        Set Rg = Rng.Offset(-y, 0)        Case "下"        Set Rg = Rng.Offset(y, 0)        Case "左"        Set Rg = Rng.Offset(0, -y)        Case "右"        Set Rg = Rng.Offset(0, y)    End Select    Application.ScreenUpdating = False    Rng.Parent.Select    For Each shp In ActiveSheet.Shapes    '如果旧图片存放在目标图片存放范围则删除        If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.Delete    Next    x = Rg.Row - Rng.Row    y = Rg.Column - Rng.Column    '偏移的坐标    Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")    '用数组变量记录五种文件格式    For Each Cll In Rng    '遍历选择区域的每一个单元格        strPicName = Cll.Text        '图片名称        If Len(strPicName) Then        '如果单元格存在值            strPicPath = strFdPath & strPicName            '图片路径            pd = 0            'pd变量标记是否找到相关图片            For i = 0 To UBound(Arr)            '由于不确定用户的图片格式，因此遍历图片格式                If Len(Dir(strPicPath & Arr(i))) Then                '如果存在相关文件                    Set shp = ActiveSheet.Shapes.AddPicture( _                        strPicPath & Arr(i), False, True, _                        Cll.Offset(x, y).Left + 5, _                        Cll.Offset(x, y).Top + 5, _                        20, 20)                    shp.Select                    With Selection                        .ShapeRange.LockAspectRatio = msoFalse                        '撤销锁定图片纵横比                        .Height = Cll.Offset(x, y).Height - 10 '图片高度                        .Width = Cll.Offset(x, y).Width - 10 '图片宽度                    End With                    pd = 1 '标记找到结果                    n = n + 1 '累加找到结果的个数                    [a1].Select: Exit For '找到结果后就可以退出文件格式循环                End If            Next            If pd = 0 Then k = k + 1 '如果没找到图片累加个数        End If    Next    Application.ScreenUpdating = True    MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片 。"End Sub


推荐阅读


上一篇：天主教教皇为什么在梵蒂冈了

下一篇：孙尚香嫁给刘备后来怎么样了