Question

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

＆＃34;目前无法显示此图片。＆＃34;

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

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

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年有这个问题。我知道两种可能的解决方法：< / p>

1）您可以尝试不关闭源工作簿，直到之后打开屏幕更新。这对我来说感觉有点疯狂，因为我不知道为什么这样做的确切机制。此外，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

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

1 个答案:

代码示例：