Excel VBA代码移动工作表与图像添加屏幕更新和错误 [英] Excel VBA code to move worksheets with image add screen updating and it errors

问题描述

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

此图片目前无法显示。

我已经做了一些研究，没有发现任何关于这个具体的错误。一个解决方案表明，在没有屏幕更新的过程中，我更改为空白页，但是它没有起作用。基于其他帖子，如果复制工作表而不是移动工作表，则会出现错误，因为图像不是单元格的一部分。

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

  Sub GetSheets（）
 
 Application.DisplayAlerts = False 
 Application.ScreenUpdating = False 
 
 Path =G：\Project Dashboards\Testing Folder\
 
 Filename = Dir（Path& * .xls）
尽管文件名<> 
 
 Workbooks.Open文件名：= Path&文件名，UpdateLinks：= True，ReadOnly：= True 
工作簿（文件名）。激活
 
表格（1）。之后：= ThisWorkbook.Sheets（1）
 ActiveSheet。 Name = ActiveSheet.Cells（2，17）.Value 
 
工作簿（文件名）.Close False 
文件名= Dir（）
循环
 
 ActiveWorkbook .Save 
 Application.ScreenUpdating = True 
 
 End Sub 
  

如果您注释掉 Application.ScreenUpdating = False 图像将根据需要与工作表一起移动。

解决方案

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

1）您可以尝试关闭源工作簿，直到 后，您开启屏幕更新。这对我来说感觉到一点点的货物文化，因为我不知道为什么这个工作的确切机制。另外，IIRC我认为它不适用于插入链接的图像。

2）您可以尝试使用Range.Copy，它应该与任何图像一起使用

---

代码示例：

代码示例完全未经测试

选项1：

  Sub GetSheets（）
 
 Application.DisplayAlerts = False 
 Application.ScreenUpdating = False 
 
 Path =G：\Project Dashboards\Testing Folder\
 
 Filename = Dir（Path&* .xls） 
尽管文件名<> 
 
 Workbooks.Open文件名：= Path&文件名，UpdateLinks：= True，ReadOnly：= True 
工作簿（文件名）。激活
 
表（1）.Move（之后：= ThisWorkbook.Sheets（1））。Name = ActiveSheet .Cells（2，17）.Value 
 
'工作簿（文件名）.Close False 
文件名= Dir（）
循环
 
 ThisWorkbook.Save 
 Application.ScreenUpdating = True 
 
 Dim Book as Workbook 
对于工作簿中的每本书
如果Not Book是ThisWorkbook然后Book.Close False 
下一个
 
 End Sub 
  

选项2：

  Sub GetSheets（）
 
 Application.DisplayAlerts = False 
 Application.ScreenUpdating = False 
 
路径=G：\Project Dashboards\Testing Folder\
 
 Dim SourceBook as Workbook 
 Dim TargetBook as Workbook 
 Dim OldSheet as Worksheet 
 Dim NewSheet as工作表
 
文件名=目录（路径&.xls）
尽管文件名<> 
 Set TargetBook = ThisWorkbook 
 Set Sourcebook = Workbooks.Open文件名：= Path&文件名，UpdateLinks：= True，ReadOnly：= True 
'工作簿（文件名）。激活
设置OldSheet = Sourcebook.Sheets（1）
设置NewSheet = TargetBook.Worksheets.Add（之后： = TargetBook.Sheets（1））
 NewSheet.Name = OldSheet.Cells（2，17）.Value 
 OldSheet.Cells.Copy目的地：= NewSheet.Cells（1,1）
 Sourcebook.Close False 
文件名= Dir（）
循环
 
 TargetBook.Save'我假设您要将工作簿保存到
中Application.ScreenUpdating = True 
 
 End Sub 
  

I have an Excel 2010 macro that opens all workbooks in a given folder and moves Sheet1 from the new workbooks into a Master Workbook, which was working but extremely slow. Today I updated it to include Application.ScreenUpdating = False to cut down on the processing time. There is a logo on Sheet1 and with the screen updating addition the logo is now showing the following error:

"This image cannot currently be displayed."

I have done some research and have not found anything on this specific error. One solution suggested that I change to a blank page during the processing without screen updating, however it did not work. Based on other posts the error occurs frequently if you copy a worksheet, rather than move it, because the image is not part of a cell.

Below is a simplified version of the code I am using that still causes the error:

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

If you comment out Application.ScreenUpdating = False the image is moved with the worksheet as desired.

解决方案

Okay, so I don't know the exact cause (sorry - I have not seen an explanation for this yet) but I do know there is an issue with this in 2010. I know of two possible workarounds:

1) you can try not closing the source workbooks until after you turn on screen updating. This to me feels a little cargo cultish as I don't know the exact mechanism behind why this works. Also, IIRC I don't think it works with images inserted as links.
2) you can try using Range.Copy, which should work with any image

---

Code Examples:

Code examples are totally untested
Option 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

option 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代码移动工作表与图像添加屏幕更新和错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！