vba - Excel VBA代码移动带有图像的工作表添加屏幕更新和错误

Question

我有一个 Excel 2010 宏，可以打开给定文件夹中的所有工作簿，并将 Sheet1 从新工作簿移动到主工作簿中，该工作簿正在工作但速度极慢。今天我更新了它以包含 Application.ScreenUpdating = False以减少处理时间。 Sheet1 上有一个 Logo ，并且随着屏幕更新添加，该 Logo 现在显示以下错误:

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

我做了一些研究，没有发现任何关于这个特定错误的信息。一种解决方案建议我在处理过程中更改为空白页面而不进行屏幕更新，但它不起作用。根据其他帖子，如果您复制工作表而不是移动它，则会经常发生错误，因为图像不是单元格的一部分。

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

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)您可以尝试在打开屏幕更新之前不要关闭源工作簿。这对我来说有点像 cargo 崇拜，因为我不知道它为什么起作用的确切机制。此外，IIRC 我认为它不适用于作为链接插入的图像。
2)您可以尝试使用 Range.Copy，它应该适用于任何图像

代码示例:

代码示例完全未经测试
选项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