CODEWITHSUNDEEP
vbaexcel
SarahVBA
SarahVBA

Reputation: 23

Excel VBA code to move worksheets with image add screen updating and it errors

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.

Upvotes: 2

Views: 835

Answers (1)

CBRF23
CBRF23

Reputation: 1518

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

Upvotes: 1

Related Questions