工作表中批量插入同一文件夹下图片到单元格中并对准.doc

工作表中批量插入同一文件夹下图片到单元格中并对准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.getopenfilename(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.screenupdating = 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 遍历所有工作表中图形 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 else 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 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.screenupdating = 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 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,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 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.screenupdating = 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 = 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试验了一下，确实很好用，高手。但我还有个要求，比如说有两行，第一行是姓名，第二行能不能将按第一行的姓名插入照片（照片以姓名命名），对号入座。谢谢！ 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 = 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.getopenfilename(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(filename, 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 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 rng.selectend sub我还有个要求，比如说有两列(有上千行），第一列是姓名，第二列能不能将按第一列的姓名插入照片（照片以姓名命名），对号入座。谢谢！香川群子老师在五楼编的vba好像是针对行解决问题的！按某列插入图片最好 . 这个应该你自己学会去修改参数。简化版如下：红色部分参数自己根据需要修改sub autopicinsert() application.screenupdating = false 自己修改图片所在文件夹吧。（取消了选择对话框） mydir = d:backup我的文档复件图片 直接引用jpg格式。(取消了39种格式) 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 上面这句红色部分自己根据需要修改吧。现在是从b4开始按列搜索图片名称的意思。 if err.number 0 then err.clear else activecell.offset(0, 4).select if activecell 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 = 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您在以上的宏，我试了，有这么几点尚不能满足我的要求（其中红色部分的参数修改我基本琢磨清楚了）请帮助：1.图片好像只能插入四行就不往下走了。2.插入的图片，改变图片所在单元格的宽度时，图片会随着单元格的大小而变；但是改变单元格的高度时，图片却没有随之变化。希望达到图片随单元格的高度及宽度同时变化。多次麻烦，实在抱歉！回答1：图片如果只能插入4行，就不走下去了，我猜测可能的原因是：你在文件中的名称和实际文件夹中符合名称的图片，完全符合的只有4个。回答2：我目前的代码，考虑到图片的宽和高度最好和原来的比例保持一致。所以，改变高度时不能完全跟随变化。只要把代码改成下面这样就行了。sub autopicinsert() application.screenupdating = false 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 activecell.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 = 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 activecell.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 = 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