Excel VBA-код для перемещения листов с обновлением экрана изображения и ошибок
У меня есть макрос Excel 2010, который открывает все книги в данной папке и перемещает Sheet1 из новых книг в рабочую книгу мастера, которая работает, но очень медленная. Сегодня я обновил его, включив Application.ScreenUpdating = False чтобы сократить время обработки. На листе 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) ActiveSheet.Name = ActiveSheet.Cells(2, 17).Value Workbooks(Filename).Close False Filename = Dir() Loop 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") 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