奔牛网>office>Excel应用>>EXCEL批量插图的几种方法(含批注插图,VBA插图,以及用插图公式插入图片)
2017年08月18日

EXCEL批量插图的几种方法(含批注插图,VBA插图,以及用插图公式插入图片)

Excel应用过程中基本都会遇到根据货号插入对应图片的这种应用方式,而插入图片又分插到某个格子里和插到批注里两种方式。
这里例举了几种常用的插图方式,包括用VBA宏和用插图公式<TABLE><img src="">等方式


一、插图到单元格批注里面,鼠标移过去才显示图片
这种方式只能用宏来实现快速插图
宏如下:
给两个宏做参考,第一个宏比较智能可以选择图片文件夹,还可以设置图片大小。第二个宏就是设定格式直接执行就行,这个就要看运用环境来选择了

宏一:插入批注图片(可以选择存放文件夹,可以设定图片大小)
Sub pictopz()
    Dim cell As Range, fd, t, w As Byte, h As Byte
    Set fso = CreateObject("scripting.filesystemobject")
    Selection.ClearComments
    If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
    On Error GoTo err
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If
    w = Application.InputBox("您希望插入的图片显示多宽?" & Chr(10) & "Excel默认宽度为3.39,你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认宽度", 3.39, , , , , 2)
    h = Application.InputBox("您希望插入的图片显示多高?" & Chr(10) & "Excel默认高度为2.09,你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认高度", 2.09, , , , , 2)
    If w < 1 Or h < 1 Then w = 3.39: h = 2.09
    If w > 15 Or h > 15 Then MsgBox "原则上你的图片可以显示这么大," & Chr(10) & "不过有必要吗?请重新输入1-15之间的数", 64, "提示": Exit Sub
    For Each cell In Selection
                       pics = t & "\" & cell.Text & ".jpg"
                       If fso.fileexists(pics) Then
                 With cell.AddComment
                     .Visible = True
                     .Text Text:=""
                     .Shape.Select True
                     With Selection.ShapeRange
                         .Fill.UserPicture pics
                         .ScaleWidth w / 3, msoFalse, msoScaleFromTopLeft
                         .ScaleHeight h / 2.09, msoFalse, msoScaleFromTopLeft
                     End With
                     cell.Offset(1, 0).Select
                     .Visible = False
                 End With
        end if
    Next
    Exit Sub
err:
    ActiveCell.ClearComments
    MsgBox "未找到同名的JPG图片!", 64, "提示"
End Sub




宏二:插入批注图片(输入图片地址)
Sub add()
Set fso = CreateObject("scripting.filesystemobject")
For Each cell In Selection
pics = "请复制图片所在文件的地址粘贴在此处,替换本段文字\" & cell.Value & ".jpg"
If fso.fileexists(pics) Then
With cell.AddComment
.Shape.Fill.UserPicture picturefile:=pics
.Shape.Height = 200
.Shape.Width = 150
End With
End If
Next cell
End Sub
顶(0)
踩(0)
最新评论