Excel VBA代码移动工作表与图像添加屏幕更新和错误

我有一个Excel 2010macros，可打开给定文件夹中的所有工作簿，并将Sheet1从新工作簿移到Master Workbook中，该工作簿正在工作，但速度非常慢。 今天我更新它包括Application.ScreenUpdating = False减less处理时间。 Sheet1上有一个标志，随着屏幕更新，标志现在显示如下错误：

“此图片目前无法显示。”

我已经做了一些研究，并没有发现这个具体的错误。 一个解决schemebuild议我在没有更新屏幕的情况下更改为空白页面，但是不起作用。 根据其他post，如果复制工作表而不是移动它，频繁出现错误，因为图像不是单元格的一部分。

下面是我正在使用的代码的简化版本仍然导致错误：

 Sub GetSheets() Application.DisplayAlerts = False Application.ScreenUpdating = False Path = "G:\Project Dashboards\Testing Folder\" Filename = Dir(Path & "*.xls") Do While Filename <> "" Workbooks.Open Filename:=Path & Filename, UpdateLinks:=True, ReadOnly:=True Workbooks(Filename).Activate Sheets(1).Move after:=ThisWorkbook.Sheets(1) ActiveSheet.Name = ActiveSheet.Cells(2, 17).Value Workbooks(Filename).Close False Filename = Dir() Loop ActiveWorkbook.Save Application.ScreenUpdating = True End Sub 

如果注释掉Application.ScreenUpdating = False ，图像将随工作表一起移动。

Answer 1

好的，所以我不知道确切的原因（对不起 – 我还没有看到这方面的解释），但我知道2010年有这个问题。我知道两种可能的解决方法：

1）您可以尝试closures源工作簿，直到您打开屏幕更新。 这对我来说感觉有点货真价实，因为我不知道为什么这样做的确切机制。 此外，IIRC我不认为它适用于作为链接插入的图像。
2）你可以尝试使用Range.Copy，它应该适用于任何图像

---

代码示例：

代码示例完全未经testing
选项1：

 Sub GetSheets() Application.DisplayAlerts = False Application.ScreenUpdating = False Path = "G:\Project Dashboards\Testing Folder\" Filename = Dir(Path & "*.xls") Do While Filename <> "" Workbooks.Open Filename:=Path & Filename, UpdateLinks:=True, ReadOnly:=True Workbooks(Filename).Activate Sheets(1).Move (after:=ThisWorkbook.Sheets(1)).Name = ActiveSheet.Cells(2, 17).Value 'Workbooks(Filename).Close False Filename = Dir() Loop ThisWorkbook.Save Application.ScreenUpdating = True Dim Book as Workbook For Each Book in Workbooks If Not Book Is ThisWorkbook then Book.Close False Next End Sub 

选项2：

 Sub GetSheets() Application.DisplayAlerts = False Application.ScreenUpdating = False Path = "G:\Project Dashboards\Testing Folder\" Dim SourceBook as Workbook Dim TargetBook as Workbook Dim OldSheet as Worksheet Dim NewSheet as Worksheet Filename = Dir(Path & "*.xls") Do While Filename <> "" Set TargetBook=ThisWorkbook Set Sourcebook=Workbooks.Open Filename:=Path & Filename, UpdateLinks:=True, ReadOnly:=True 'Workbooks(Filename).Activate Set OldSheet=Sourcebook.Sheets(1) Set NewSheet=TargetBook.Worksheets.Add (After:=TargetBook.Sheets(1)) NewSheet.Name = OldSheet.Cells(2, 17).Value OldSheet.Cells.Copy Destination:=NewSheet.Cells(1,1) Sourcebook.Close False Filename = Dir() Loop TargetBook.Save 'I assumed you wanted to save the workbook you added sheets to Application.ScreenUpdating = True End Sub