一、从Excel图片批量嵌入单元格
在Excel中,我们可以将图片嵌入单元格中,这样可以保证图片与单元格的对应关系,也方便对单元格和图片的移动和复制。
Sub Insert_Picture_Into_Cell()
Dim strPic As String
strPic = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp), *.gif;*.jpg;*.bmp", MultiSelect:=True)
If strPic = "False" Then Exit Sub
Dim cell As Range
For Each cell In Selection
If cell.Row = ActiveCell.Row Then
cell.Select
If Len(strPic) > 0 Then
cell.Activate
ActiveSheet.Pictures.Insert(strPic).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = cell.Width - 2
.Height = cell.Height - 2
.Top = cell.Top + 1
.Left = cell.Left + 1
End With
End If
End If
Next
End Sub
二、Excel批量导入多张图片并自动排版
如果我们需要一次性导入多张图片并自动排版,可以使用以下代码:
Sub Insert_Multiple_Pictures()
Dim strPath As String
strPath = "C:\Pictures\" '图片所在文件夹路径
Dim imgExtension As String
imgExtension = "*.jpg" '图片扩展名
Dim rowIndex As Integer
rowIndex = 1 '从第一行开始插入图片
Dim colIndex As Integer
colIndex = 1 '从第一列开始插入图片
Dim picTop As Double
picTop = Cells(rowIndex, colIndex).Top '图片顶部位置
Dim picLeft As Double
picLeft = Cells(rowIndex, colIndex).Left '图片左侧位置
Dim picWidth As Double
picWidth = Cells(rowIndex, colIndex).Width '图片宽度
Dim picHeight As Double
picHeight = Cells(rowIndex, colIndex).Height '图片高度
Dim imgCount As Integer
imgCount = 0 '已插入图片数量
Dim pic As Picture
For Each pic In ActiveSheet.Pictures
pic.Delete
Next pic
Dim strFile As String
strFile = Dir(strPath & imgExtension)
Do While Len(strFile) > 0
Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
pic.Top = picTop
pic.Left = picLeft
pic.Width = picWidth
pic.Height = picHeight
If colIndex < 4 Then
colIndex = colIndex + 1
Else
colIndex = 1
rowIndex = rowIndex + 1
End If
If rowIndex > 20 Then Exit Do '插入图片20张后退出
picTop = Cells(rowIndex, colIndex).Top
picLeft = Cells(rowIndex, colIndex).Left
picWidth = Cells(rowIndex, colIndex).Width
picHeight = Cells(rowIndex, colIndex).Height
strFile = Dir
imgCount = imgCount + 1
Loop
MsgBox imgCount & "张图片已成功导入到Excel中!"
End Sub
三、Excel批量导入对应图片
如果我们有一份表格,需要根据表格中每行数据对应的图片来批量导入图片,可以使用以下代码:
Sub Insert_Picture_By_Match()
Dim strPath As String
strPath = "C:\Pictures\" '图片所在文件夹路径
Dim imgExtension As String
imgExtension = "*.jpg" '图片扩展名
Dim picTop As Double
picTop = 0 '图片顶部位置
Dim picLeft As Double
picLeft = 0 '图片左侧位置
Dim picWidth As Double
picWidth = 100 '图片宽度
Dim picHeight As Double
picHeight = 100 '图片高度
Dim i As Integer
For i = 2 To 10 '从第2行开始
picTop = ActiveSheet.Cells(i, 3).Top '图片所在行第3列
picLeft = ActiveSheet.Cells(i, 4).Left '图片所在行第4列
strFile = Dir(strPath & Left(ActiveSheet.Cells(i, 5).Value, 3) & imgExtension) '根据数据中的名称匹配图片
Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
pic.Top = picTop
pic.Left = picLeft
pic.Width = picWidth
pic.Height = picHeight
Next i
MsgBox "图片已成功导入到Excel中!"
End Sub
四、Excel中快速批量导入图片
如果我们只需要快速地将图片批量导入到Excel中,可以使用以下方法: 在Excel中,我们可以直接通过复制粘贴的方式将图片导入到单元格中。 步骤如下:
- 打开图片文件夹和Excel表格文件,分别在Windows资源管理器和Excel中选中需要导入图片的单元格;
- 在资源管理器中选中需要导入的图片文件,使用Ctrl+C复制或者右键菜单复制;
- 在Excel表格中单击需要导入图片的单元格,使用Ctrl+V粘贴或者右键菜单粘贴。
五、Excel批量导入图片对应名称
如果我们有一批图片,需要将图片名称对应到Excel表格中的姓名列,可以使用以下代码:
Sub Insert_Picture_By_Name()
Dim strPath As String
strPath = "C:\Pictures\" '图片所在文件夹路径
Dim imgExtension As String
imgExtension = "*.jpg" '图片扩展名
Dim imgCount As Integer
imgCount = 0 '导入图片数量
Dim strFile As String
strFile = Dir(strPath & imgExtension)
Dim r As Range
For Each r In ActiveSheet.Range("A1:A10") '以A1:A10范围内的姓名为图片名称
strFile = Dir(strPath & Left(r.Value, 3) & imgExtension)
Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
pic.Top = r.Top
pic.Left = r.Left + r.Width + 5 '将图片放在姓名列的右侧5个单元格
pic.Width = 100
pic.Height = 100
imgCount = imgCount + 1
Next r
MsgBox imgCount & "张图片已成功导入到Excel中!"
End Sub
六、Excel批量导入图片按姓名并选取
如果我们需要将图片按姓名进行导入,并且可以手动选取图片,可以使用以下代码:
Sub Insert_Picture_By_Select()
Dim strPath As String
strPath = "C:\Pictures\" '图片所在文件夹路径
Dim imgExtension As String
imgExtension = "*.jpg" '图片扩展名
Dim imgCount As Integer
imgCount = 0 '导入图片数量
Dim strFile As String
strFile = Dir(strPath & imgExtension)
Dim r As Range
For Each r In ActiveSheet.Range("A1:A10") '以A1:A10范围内的姓名为图片名称
strFile = Dir(strPath & Left(r.Value, 3) & imgExtension)
If Len(strFile) = 0 Then
MsgBox "未找到名为" & Left(r.Value, 3) & "的照片。"
Exit Sub
End If
Dim pic As Picture
Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
pic.Top = r.Top
pic.Left = r.Left + r.Width + 5 '将图片放在姓名列的右侧5个单元格
pic.Width = 100
pic.Height = 100
imgCount = imgCount + 1
Dim picPath As String
picPath = strPath & strFile
Set pic = Nothing
strFile = Dir
ActiveSheet.Shapes.Range(Array(pic.Name)).OnAction = "Select_Picture('" & picPath & "')"
Next r
MsgBox imgCount & "张图片已成功导入到Excel中!"
End Sub
Function Select_Picture(picPath)
Dim pic As Picture
Set pic = ActiveSheet.Pictures.Insert(picPath)
pic.Top = ActiveCell.Top
pic.Left = ActiveCell.Left
pic.Width = ActiveCell.Width
pic.Height = ActiveCell.Height
Set pic = Nothing
End Function