这次的情况是悟空问答网友提问的。 以前因为时间的关系,没有给出简单和具体的实现方法,但是今天花了很长时间总结成文字写了。 我希望伙伴们都能学会。 @沉默的生物钟
实际问题
一、数据模拟--素材准备
为了更真实地恢复提问者遇到的问题,需要准备包含600个Excel文件和2个图像的文件。
一两个文件可以手动重新制作。 这是600个文件啊。 不要担心。 既然我们用VBA解决问题,解决这种事情重复机械劳动当然不难。 图像以test1.png和test2.png的名称放置在当前文件目录中,模拟数据时将test1.png插入到第一个表中,将test2.png插入到第二个工作表中。
test1.png
测试2.png
二、数据模拟--分步操作过程
第一步:创建新的Excel文件,并将其保存为. xlsm格式。
启用宏的工作簿
步骤:打开新创建的. xlsm文件,按快捷键ALT F11进入VBE界面。
进入VBE界面
步骤3:在vbe项目中插入模块。
插入模块
步骤:在新制作的模块上粘贴以下代码。
Sub将生成600个Excel文件,包括图像(
'关闭刷新,防止画面抖动
应用程序.屏幕更新=假
'定义变量I
dim I as集成器
'定义I是从1个循环到600个循环
For i=1 To 600
'添加工作簿
工作区添加
'在工作簿的第一个工作表中插入图像test1.png
活动工作簿. sheets (1) .图片插入) this工作簿.路径' 测试1.png ' ) .选择
'在工作簿的第二个工作表中插入图像test2.png
活动工作簿. sheets (2) .图片插入) this工作簿.路径' 测试2.png ' ) .选择
'将工作簿保存到当前路径
active workbook .另存为this workbook .路径'' I '.xlsx '
'关闭工作簿
活动工作簿.结算
'继续循环创建新工作簿
下一个
'重新启动画面刷新
应用程序.屏幕更新=真
'处理完成后发出提示
msgbox '包含600个图像的excel文件生成完成!' 、VB信息、“提示信息”
终点s
ub第五步:执行VBA代码,生成我们需要的600个Excel文件
三、数据模拟--连贯操作演示:
四、图片导出--解决思路
600个案例文件已经准备好了,接下来就是导出文件中的图片:
1. 找出当前目录下的所有Excel文件。
2. 打开找到的Excel文件。
3. 找出Excel文件中的所有工作表。
4. 找出工作表中的所有图片对象。
5. 把找到的每一个图片导出到当前目录下。
如果文件不多的情况下,按上面的思路手动操作导出也是可以的,其实通过VBA来解决问题也是要先把复杂问题进行简单化,一步步进行分解问题,最终形成完整解决方案。VBA代码使用方式在上面数据准备过程中已经有详细描述了,本次我们直接来运行下代码,实现导出文件中的图片。
Sub 导出当前路径下工作簿中的图片() Dim wk$ '定义为工作簿文件 Dim i As Integer '定义工作簿中的工作表数量 Dim ii As Integer '定义为工作表中的对象个数 '关闭刷新,防止抖动 Application.ScreenUpdating = False '遍历第一个工作簿文件 wk = Dir(ThisWorkbook.Path & "*.xlsx") '遍历到的文件名不等于空的情况下 Do While wk <> "" '如果文件名称和当前的名称是不一样的。 If wk <> ThisWorkbook.Name Then '打开遍历到的工作簿 Workbooks.Open (ThisWorkbook.Path & "" & wk) '对打开的工作簿文件进行以下操作 With ActiveWorkbook '循环出工作簿中的每一个工作表 For i = 1 To .Sheets.Count '循环出工作表中的每一个对象shape For ii = 1 To .Sheets(i).Shapes.Count '临时变量,统计shape的个数 k = k + 1 '复制shape对象 .Sheets(i).Shapes(ii).Copy '创建一个图表对象,宽高与与对象保持一致 With .Sheets(i).ChartObjects.Add(0, 0, .Sheets(i).Shapes(ii).Width, .Sheets(i).Shapes(ii).Height).Chart '把图片插入进去 .Paste '通过图表对象的导出方法,把图片导出到当前目录下 .Export ThisWorkbook.Path & "" & wk & "_" & k & ".png" '删除图表 .Parent.Delete End With Next Next '关闭打开的工作簿 .Close False End With End If '继续遍历下一个工作簿 wk = Dir Loop '开启屏幕刷新 Application.ScreenUpdating = True MsgBox "600个含图片的Excel文件图片导出完成!", vbInformation, "提示信息" End Sub五、图片导出--操作演示
小伙伴们,如果VBA代码有做注释说明,如有任何问题欢迎,评论区讨论,谢谢!