VBA循环将图片放入单元格导致Excel无提示崩溃

问题根源分析 #

你的宏出现崩溃主要有两个核心问题：

1. If语句语法错误：原代码里的下划线仅让shp.Select属于If判断的执行内容，shp.PlacePictureInCell会被无条件执行，不管形状是否在目标区域内，大量无意义操作直接触发Excel崩溃。
2. 对象未就绪+不稳定操作：快速运行时，图片粘贴还没完成、Excel未将图片加入Shapes集合，循环就开始遍历未就绪的对象，直接导致程序无响应关闭。另外，频繁用Select/Activate会引发对象引用混乱，进一步降低宏的稳定性。

修复后的代码 #

Dim wb1 As Excel.Workbook
Set wb1 = ActiveWorkbook
Dim homesheet As Excel.Worksheet
Set homesheet = ActiveSheet
Dim wb2 As Excel.Workbook
Set wb2 = Workbooks.Open("https://fcx365.sharepoint.com/:x:/r/Sites/STO-Laboratory/General%20Documents/Fluoride%20Report%20template.xlsx")

' [保留你复制粘贴数据的原有代码]

' 复制图片，跳过Select操作
wb1.Sheets("fluoride uncertainties").Range("A1:L48").CopyPicture xlPrinter

' 明确引用目标工作表和区域，粘贴后直接获取图片对象
Dim targetWs As Worksheet
Set targetWs = wb2.ActiveSheet ' 也可指定具体工作表，比如wb2.Sheets("报表模板")
Dim targetRng As Range
Set targetRng = targetWs.Range("A557:I574")

Dim pastedShp As Shape
Set pastedShp = targetWs.Shapes.PasteSpecial(Link:=False, DataType:=xlPicture)

' 直接对刚粘贴的图片执行嵌入单元格操作
pastedShp.PlacePictureInCell
' 可选：如需匹配单元格大小，可添加以下代码
' pastedShp.Top = targetRng.Top
' pastedShp.Left = targetRng.Left

关键优化说明 #

• 跳过遍历所有形状：直接获取刚粘贴的图片对象，不用循环扫遍工作表所有形状，既提升效率又避免处理未就绪的对象。
• 移除不稳定操作：全程用明确的对象引用（比如targetWs、targetRng），不再依赖ActiveSheet、Select这类容易出问题的操作。
• 修正逻辑错误：确保只对目标图片执行嵌入操作，避免无差别处理所有形状引发的崩溃。

内容的提问来源于stack exchange，提问作者Artybunny