指定名称自动批量上传图片，你的excel统计表也可以增加这个功能

今天我们来学习一下，如何在表格中，根据指定的名称自动通过代码添加指定的图片到表格的指定区域当中，这个在统计相关信息的时候非常简单和方便，不用再去确定核对名称了。

一、案例演示

根据我们上面输入的人员名字，自动添加批量人员相片。

二、操作方法

第一步：点击开发工具—Visual Basic，插入模块进入代码编辑窗口，如下图：

第二步：代码编辑窗口添加以下代码内容：

Sub InsertPic()

Dim Arr, i&, k&, n&, pd&

Dim PicName$, PicPath$, FdPath$, shp As Shape

Dim Rng As Range, Cll As Range, Rg As Range, book$

With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False

If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub

End With

If Right(FdPath, 1) <> '\' Then FdPath = FdPath & '\'

Set Rng = Application.InputBox('请选择图片名称所在的单元格区域', Type:=8)

Set Rng = Intersect(Rng.Parent.UsedRange, Rng)

If Rng Is Nothing Then MsgBox '选择的单元格范围不存在数据！': Exit Sub

book = InputBox('请输入图片偏移的位置，例如上1、下1、左1、右1', , '右1')

If Len(book) = 0 Then Exit Sub

x = Left(book, 1)

If InStr('上下左右', x) = 0 Then MsgBox '你未输入偏移方位。': Exit Sub

y = Val(Mid(book, 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

PicName = Cll.Text

If Len(PicName) Then

PicPath = FdPath & PicName

pd = 0

For i = 0 To UBound(Arr)

If Len(Dir(PicPath & Arr(i))) Then

ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select

With Selection

.ShapeRange.LockAspectRatio = msoFalse

.Top = Cll.Offset(x, y).Top + 5

.Left = Cll.Offset(x, y).Left + 5

.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

MsgBox '共处理成功' & n & '个图片，另有' & k & '个非空单元格未找到对应的图片。'

Application.ScreenUpdating = True

End Sub

三、代码基本介绍

1、 Dim Rng As Range, Cll As Range, Rg As Range, book$：定义文件夹，选择相片所在文件夹路径；

2、 Set Rng = Application.InputBox：定义图片名称，选择需要添加图片的名称区域；

3、 book = InputBox('请输入图片偏移的位置，例如上1、下1、左1、右1', , '右1')：判断你需要添加的图片位置在你名称的位置关系，偏移的值是多少；

4、 Arr = Array('.jpg', '.jpeg', '.bmp', '.png', '.gif')：创建数组，确定允许上传的图片格式类型。