Sub Show_Picture()
dim r = 1: c = 0
Pf = "ai,"
Pf = Pf & "bmp,bmz,"
Pf = Pf & "cdr,cgm,"
Pf = Pf & "dib,dwg,dxf,"
Pf = Pf & "emf,emz,eps,exf,exif,"
Pf = Pf & "fpx,"
Pf = Pf & "gfa,gif,"
Pf = Pf & "hdr,"
Pf = Pf & "ico,"
Pf = Pf & "jfif,jpe,jpeg,jpg,"
Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"
Pf = Pf & "raw,rle,"
Pf = Pf & "svg,"
Pf = Pf & "tga,tif,tiff,"
Pf = Pf & "ufo,"
Picformat = Pf & "wdp,wmf,wmz,"
myDir = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Filename = Dir(myDir)
ThisWorkbook.Sheets("最终显示界面").Select
Do While Filename <> ""
If InStr(Picformat, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
PicName = Left(Filename, InStrRev(Filename, ".") - 1)
Range("B5,C5,D5,E5,F5,G5,H5,I5,J5,L5,M5,N5,O5,Q5,R5,S5,T5,X5,Y5,C9,D9,E9,F9,G9,H9,I9,J9,L9,M9,N9,O9,Q9,R9,S9,T9,X9,Y9,T13,X13,Y13").Select
On Error Resume Next
Selection.Find(What:=PicName, After:=ActiveCell, LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate
If Err.Number <> 0 Then
Err.Clear
Else
ActiveSheet.Pictures.Insert(myDir & Filename).Select
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Offset(r, c).Top
.Left = ActiveCell.Offset(r, c).Left
.Height = ActiveCell.Offset(r, c).Height
.Width = ActiveCell.Offset(r, c).Width
End With
End If
End If
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
单元格里显示图片（对应上面单元格名字)/多种后缀图片格式文件打开方式
原文：https://www.cnblogs.com/jingxinmanong/p/12487486.html