《工作表中批量插入同一文件夹下图片到单元格中并对准.doc》由会员分享，可在线阅读，更多相关《工作表中批量插入同一文件夹下图片到单元格中并对准.doc（9页珍藏版）》请在三一办公上搜索。
1、工作表中批量插入同一文件夹下图片到单元格中并对准8楼代码已经完全改变思路，效率更高更可靠。本楼代码可以无视，仅作学习参考用。Sub PicBatchIn() K = InputBox(请输入插入图片换行数，默认10张, 插入图片换行数, 10) 指定插入满10张图片后换行。当然可以根据需要改成k=5或者k=20之类的。 If K = Then K = 1 如果选择ESC退出输入对话框，则把k值设定为1，即在同一列中按行插入。 Dim r As Range: Set r = ActiveCell 指定当前单元格为开始插入图片的位置。 OpenFile = Application.GetOpenF
2、ilename(Picture Files(*.jpg),*.jpg, , Get Picture from here!) 找到目标文件夹，并随便选取一张jpg图片。 如果图片格式不是*.jpg，请修改代码，如同下面： OpenFile = Application.GetOpenFilename(Picture Files(*.bmp),*.bmp, , Get Picture from here!) 找到目标文件夹，并随便选取一张bmp图片。 If OpenFile = False Then Exit Sub 如果选择为空或ESC，则结果为错误退出此vba过程。 Application.Sc
3、reenUpdating = False 暂停屏幕刷新 L = InStrRev(OpenFile, ) 查找最后一个文件夹特定字符 myDir = Left(OpenFile, L) 抽取所选文件夹字符，如D:Documents P = Dir(myDir & *.jpg) 用Dir命令寻找jpg图片。（或改为bmp图片） ActiveSheet.Pictures.Insert (myDir & P) 插入第一张图片 下面部分代码，是为了找到现在工作表中自动赋值的图片序号 Dim Shp As Shape For Each Shp In ActiveSheet.Shapes 遍历所有工作表中
4、图形 ShpNm = Shp.Name 得到每个图形的名称 PicNo = Val(Mid(ShpNm, InStr(ShpNm, ), Len(ShpNm) 查找空格并取其后的数值为图片序号。 If PicNo m Then m = PicNo 使N变量保持为较大值，直至遍历循环结束，即可找到最大值。 Next Do While P 循环直至结束。 r.Cells(1 + n k, n Mod k + 1).Select 选择将要插入图片的单元格，并按照指定k参数换行 即把n除以k以后的整数部分作为换行顺序值，而n对于k的余数部分作为列顺序值。 If U = 0 Then U = 1 Els
5、e ActiveSheet.Pictures.Insert (myDir & P) 除第一张以外，每次插入新图片 ActiveSheet.Shapes.Range(图片 & m + n).Select 选择刚才插入的图片，已有图片序号m+新插入数n。 ActiveSheet.Shapes.Range(Picture & m + n).Select 在英文版中的代码图片=Picture。 以下是确定让图片顶部、左侧位置以及图片高、宽对准单元格 With Selection .Top = r.Cells(1 + N K, N Mod K + 1).Top .Left = r.Cells(1 + N
6、 K, N Mod K + 1).Left .ShapeRange.LockAspectRatio = msoFalse 设置图片格式为高宽不按比例变化。 .Height = r.Cells(1 + N K, N Mod K + 1).Height .Width = r.Cells(1 + N K, N Mod K + 1).Width .Placement = xlMoveAndSize 设置图片格式为跟随单元格大小变化。 End With n = n + 1 图片序号+1 P = Dir 用Dir命令继续下一张图片，直至内容为空 Loop Application.ScreenUpdatin
7、g = True 打开屏幕刷新 r.Select 回到起始单元格。End Sub再次提醒，本代码不如8楼的代码好 ！=在这里，n k 是 int(n/k)的简写。现在的代码，已经解决了同一工作表中，新插入图片序号不为1的问题。另外，实际上，如果最初把换行列数的k值定为1的话，宏运行的结果，就可以变成了在同一列里按行排序插入的结果了而如果定义的换行k值大于文件夹中图片数量，当然就变成了在同一行里按列插入的结果了。If U = 0 Then U = 1 Else ActiveSheet.Pictures.Insert (myDir & P) 除第一张以外，每次插入图片对上面这句代码解释如下：If
8、U = 0 Then U = 1 处理第一张图片时，不需要再作图片插入，但要做好首件U标记。Else ActiveSheet.Pictures.Insert (myDir & P) 如果首件U标记已经不为0时则要插入图片End If使用vba批量导入同一文件夹下的图片，并按列排序放置，大小对准单元格。Sub 单元格自动插入图片() 选定起始单元格后，按一定行数(1-n)自动往返插入各种格式的图片， 并在单元格中写入插入图片的名称。 Pf = ai, Pf = Pf & bmp,bmz Pf = Pf & cdr,cgm, Pf = Pf & dib,dwg,dxf, Pf = Pf & emf
9、,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, Pf = Pf & wdp,wmf,wmz, K = InputBox(插入行数，1=按列挿入, 插入行数, 1) If K = Then Exit
10、Sub Dim Rng As Range: Set Rng = ActiveCell OpenFile = Application.GetOpenFilename(Picture Files(*.*),*.*, , 打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。) If OpenFile = False Then myDir = ThisWorkbook.Path & Else myDir = Left(OpenFile, InStrRev(OpenFile, ) End If Filename = Dir(myDir) Application.S
11、creenUpdating = False Do While Filename If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, .) 0 Then Rng.Cells(1 + n K, n Mod K + 1).Select ActiveCell = Left(Filename, InStrRev(Filename, .) - 1) ActiveSheet.Pictures.Insert(myDir & Filename).Select With Selection .Placement = xlMov
12、eAndSize .ShapeRange.LockAspectRatio = msoFalse .Top = ActiveCell.Top .Left = ActiveCell.Left .Height = ActiveCell.Height .Width = ActiveCell.Width End With n = n + 1 End If Filename = Dir Loop Application.ScreenUpdating = True Rng.SelectEnd Sub试验了一下，确实很好用，高手。但我还有个要求，比如说有两行，第一行是姓名，第二行能不能将按第一行的姓名插入照片
13、（照片以姓名命名），对号入座。谢谢！ Sub 选择范围后按姓名插入照片() Dim Rng As Range Set Rng = Selection k = MsgBox(Yes=按姓名行下插入，No=按姓名列右挿入,Cancel=直接覆盖插入, vbYesNoCancel) If k = vbYes Then r = 1: c = 0 ElseIf k = vbNo Then r = 0: c = 1 Else r = 0: c = 0 End If Pf = ai, Pf = Pf & bmp,bmz Pf = Pf & cdr,cgm, Pf = Pf & dib,dwg,dxf, Pf
14、 = 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, OpenFile = Application.GetOpenFile
15、name(Picture Files(*.*),*.*, , 打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。) If OpenFile = False Then myDir = ThisWorkbook.Path & Else myDir = Left(OpenFile, InStrRev(OpenFile, ) End If Application.ScreenUpdating = False Filename = Dir(myDir) Do While Filename If InStr(Picformat, LCase(Right(Filen
16、ame, Len(Filename) - InStrRev(Filename, .) 0 Then PicName = Left(Filename, InStrRev(Filename, .) - 1) Rng.Select On Error Resume Next Selection.Find(What:=PicName, After:=ActiveCell,LookAt:=xlWhole).Activate If Err.Number 0 Then Err.Clear Else ActiveSheet.Pictures.Insert(myDir & Filename).Select Wit
17、h 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 Rng.SelectEnd Sub我还有个要求，比如说
18、有两列(有上千行），第一列是姓名，第二列能不能将按第一列的姓名插入照片（照片以姓名命名），对号入座。谢谢！香川群子老师在五楼编的VBA好像是针对行解决问题的！按某列插入图片最好 . 这个应该你自己学会去修改参数。简化版如下：红色部分参数自己根据需要修改Sub AutoPicInsert() Application.ScreenUpdating = False 自己修改图片所在文件夹吧。（取消了选择对话框） myDir = D:Backup我的文档复件图片 直接引用jpg格式。(取消了39种格式) Filename = Dir(myDir & *.jpg) Do While Filename P
19、icName = Left(Filename, InStrRev(Filename, .) - 1) On Error Resume Next Range(B4).EntireColumn.Find(What:=PicName, After:=Range(B4), LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate 上面这句红色部分自己根据需要修改吧。现在是从B4开始按列搜索图片名称的意思。 If Err.Number 0 Then Err.Clear Else ActiveCell.Offset(0, 4).Select If Active
20、Cell Then GoTo ExtToNext Else ActiveCell = Filename rt = ActiveCell.Top rl = ActiveCell.Left rh = ActiveCell.Height rw = ActiveCell.Width ActiveSheet.Pictures.Insert(myDir & Filename).Select With Selection .Placement = xlMoveAndSize .ShapeRange.LockAspectRatio = msoFalse ph = .Height pw = .Width tm
21、= IIf(rh / ph rw / pw, rh / ph, rw / pw) 取高幅比最小 .Height = .Height * tm .Width = .Width * tm .Top = rt + (rh - .Height) / 2 .Left = rl + (rw - .Width) / 2 End With End IfExtToNext: Filename = Dir Loop Range(A1).Select Application.ScreenUpdating = TrueEnd Sub您在以上的宏，我试了，有这么几点尚不能满足我的要求（其中红色部分的参数修改我基本琢磨清
22、楚了）请帮助：1.图片好像只能插入四行就不往下走了。2.插入的图片，改变图片所在单元格的宽度时，图片会随着单元格的大小而变；但是改变单元格的高度时，图片却没有随之变化。希望达到图片随单元格的高度及宽度同时变化。多次麻烦，实在抱歉！回答1：图片如果只能插入4行，就不走下去了，我猜测可能的原因是：你在文件中的名称和实际文件夹中符合名称的图片，完全符合的只有4个。回答2：我目前的代码，考虑到图片的宽和高度最好和原来的比例保持一致。所以，改变高度时不能完全跟随变化。只要把代码改成下面这样就行了。Sub AutoPicInsert() Application.ScreenUpdating = False
23、 myDir = D:Backup我的文档复件图片 Filename = Dir(myDir & *.jpg) Do While Filename PicName = Left(Filename, InStrRev(Filename, .) - 1) On Error Resume Next Range(B4).EntireColumn.Find(What:=PicName, After:=Range(B4), LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate If Err.Number 0 Then Err.Clear Else Acti
24、veCell.Offset(0, 4).Select If ActiveCell Then GoTo ExtToNext Else ActiveCell = Filename 上面这句的代码是，如果想要插入图片的单元格是空单元格，就插入图片，并写入图片名称。 而如果已经写入了图片文件名称内容，vba则判断该图片文件已经被用过，不需要重复插入图片。 ActiveSheet.Pictures.Insert(myDir & Filename).Select With Selection .Placement = xlMoveAndSize .ShapeRange.LockAspectRatio =
25、msoFalse .Top = ActiveCell.Top .Left = ActiveCell.Left .Height = ActiveCell.Height .Width = ActiveCell.Width End With End IfExtToNext: Filename = Dir Loop Range(A1).Select Application.ScreenUpdating = TrueEnd Sub有没有办法让插入图片行自动调整到指定行高，而未插入图片行保持原行高？在代码中增加一句就可以啦If Err.Number 0 Then Err.Clear Else Active
26、Cell.Offset(0, 4).Select If ActiveCell Then GoTo ExtToNext Else ActiveCell = Filename 此处插入一句代码，意思是需要插入图片的行高调整为指定值如=88. ActiveCell.RowHeight = 87.75 而未插入图片的行高，则保持原始状态不作改变了。 ActiveSheet.Pictures.Insert(myDir & Filename).Select改进版，39种图片格式自动导入图片及名称（8楼代码，效率特高）Sub 单元格自动插入图片() Pf = ai, Pf = Pf & bmp,bmz Pf
27、 = 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, Pf = Pf & wdp,wmf,wmz,
28、 K = InputBox(插入行数，1=按列挿入, 插入行数, 1) If K = Then Exit Sub Dim Rng As Range: Set Rng = ActiveCell OpenFile = Application.GetOpenFilename(Picture Files(*.*),*.*, , Get Picture from here!) If OpenFile = False Then myDir = ThisWorkbook.Path & Else myDir = Left(OpenFile, InStrRev(OpenFile, ) End If Applic
29、ation.ScreenUpdating = False Filename = Dir(myDir) Do While Filename If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, .) 0 Then Rng.Cells(1 + n K, n Mod K + 1).Select ActiveCell = Filename Left(Filename, InStrRev(Filename, .) - 1) ActiveSheet.Pictures.Insert(myDir & Filename).Select With Selection .Placement = xlMoveAndSize .ShapeRange.LockAspectRatio = msoFalse .Top = ActiveCell.Top .Left = ActiveCell.Left .Height = ActiveCell.Height .Width = ActiveCell.Width End With n = n + 1 End If Filename = Dir Loop Application.ScreenUpdating = True Rng.SelectEnd Sub
