Excel сбой при запуске макроса, который проходит через несколько файлов

Question

Я создал макрос, который открывает несколько файлов и копирует данные из этих файлов в одну книгу. Способ работы макроса: 1) Существует основная рабочая тетрадь (целевая книга) с несколькими рабочими листами, один из рабочих листов содержит пути к файлам в столбце B. Ячейки F1 и H1 содержат две подпапки, которые указаны пользователями, и эти две ячейки добавляются в путь к файлу. Файлы называются по-разному, но все файлы содержат «Один пейджер» в имени. Поэтому я использую путь к файлу и wild card «One pager *» & «.xlsx», чтобы открыть файл. 2) Макрос проверяет, сколько строк заполнено контуром и проходит по строкам с путями, открывает каждый файл (исходную книгу), копирует указанные поля в целевой лист в основной книге и затем закрывает исходные файлы.

Macro отлично работает, когда я запускаю его шаг за шагом или когда я устанавливаю точку прерывания и запускаю один цикл за один раз, но как только я запускаю полный макрос, мой Excel падает после запуска через 5-6 файлов. Я попытался запустить тот же макрос на 4 разных компьютерах, на двух из них excel crashes при запуске макроса, на двух из них работает макрос. Два компьютера, в которых сбой макросов запускают Windows 8.1 64-битный профессионал и два, где макрос работает отлично работает Windows 7 64 и 32-разрядное предприятие, а все компьютеры имеют Office 365. Может кто-то взглянуть на код, возможно, есть что-то, что я могу оптимизировать, чтобы заставить его работать все компьютеры? Спасибо заранее

Private Sub GenerateReportOP() 
    Dim ThisWB As Workbook 
    Dim OnePager As Workbook 
    Dim ThisMacro As Worksheet 
    Dim ThisOnePage As Worksheet 
    Dim OnePagerWS As Worksheet 
    Dim LastRow1 As Long 
    Dim LastRow2 As Long 
    Dim LastRowZ As Long 
    Dim LastRowMOP As Long 
    Dim OPPath As String 
    Dim BSpath As String 
    Dim Rates As String 
    Dim i As Integer 
    Dim SubstrinLoc As Integer 

    Application.ScreenUpdating = False 
    Application.AskToUpdateLinks = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.Calculation = xlManual 

    Set ThisWB = ThisWorkbook 
    Set ThisMacro = ThisWB.Sheets("Macros") 
    Set ThisOnePage = ThisWB.Sheets("One Pagers") 

    ThisOnePage.Cells.Clear 
    LastRowMOP = ThisMacro.Range("B" & Rows.Count).End(xlUp).Row 

    i = 3 
    Do While i <= LastRowMOP 
    LastRow1 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
    If ThisMacro.Range("B" & i) <> "" Then 
    ThisOnePage.Range("B" & LastRow1 + 1) = ThisMacro.Range("A" & i) 
    ThisOnePage.Range("C" & LastRow1 + 1).Value = "FX:" 
    'just formating section 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Color = vbRed 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Size = 14 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Color = vbRed 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Size = 14 
    'Define one pager workbook 
    OPPath = ThisMacro.Range("B" & i) & ThisMacro.Range("F1") & "\" & ThisMacro.Range("H1") & "\" 
    'error handler if path is not correct 
    On Error GoTo Error_handler: 
    Set OnePager = Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 
    Set OnePagerWS = OnePager.Worksheets("Check list") 
    LastRow2 = OnePagerWS.Range("A" & Rows.Count).End(xlUp).Row 
    LastRowZ = OnePagerWS.Range("Z" & Rows.Count).End(xlUp).Row 
    'check what ratees is linked 
    Rates = OnePagerWS.Range("S8").Formula 
    SubstrinLoc = InStr(1, Rates, "FY") 
    ThisOnePage.Range("D" & LastRow1 + 1) = Mid(Rates, SubstrinLoc + 6, 13) 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Color = vbBlue 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Size = 14 
    'copy one pager 
    OnePagerWS.Range("D4").Copy 
    ThisOnePage.Range("I" & LastRow1 + 3).PasteSpecial xlPasteValues 
    ThisOnePage.Range("I" & LastRow1 + 3).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("A6:A" & LastRow2).Copy Destination:=ThisOnePage.Range("B" & LastRow1 + 2) 
    OnePagerWS.Range("J6:J" & LastRow2).Copy 
    ThisOnePage.Range("C" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("C" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("L6:L" & LastRow2).Copy 
    ThisOnePage.Range("D" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("D" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("N6:N" & LastRow2).Copy 
    ThisOnePage.Range("E" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("E" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("Q6:Q" & LastRow2).Copy 
    ThisOnePage.Range("F" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("F" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("S6:S" & LastRow2).Copy 
    ThisOnePage.Range("G" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("G" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("T6:T" & LastRow2).Copy 
    ThisOnePage.Range("H" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("H" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("Z" & LastRowZ).Copy 
    ThisOnePage.Range("I" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("I" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    LastRow2 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
    With ThisOnePage 
     .Range(.Cells(LastRow1 + 4, 1), .Cells(LastRow2, 1)) = ThisMacro.Range("A" & i) 
    End With 
    Application.CutCopyMode = False 
    OnePager.Close savechanges:=False 

    'error handler if path is not correct 
Error_handler: 
     If ThisOnePage.Range("D" & LastRow1 + 1) = "" Then 
      ThisOnePage.Range("C" & LastRow1 + 1).Value = "Unable to find One Pager, please check file or path!" 
     End If 
     Resume Next 
    End If 

    i = i + 1 
    Loop 
    ThisOnePage.Range("A:I").EntireColumn.AutoFit 
    Application.AskToUpdateLinks = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.Calculation = xlAutomatic 

    MsgBox "Finished. Please check ""One Pagers"" tab." 
End Sub 

Answer 1

Ну, Excel не должны врезаться, но в реальном мире это делает, если вы толкаете его. Вместо запуска экспериментов я переписал код, чтобы сделать его более безопасным.

Итак, как сделать код более безопасным. Ну, я предполагаю, что, может быть, проблема заключается в том, что вы обманываете буфер обмена своей копией и пастами. У меня почти нет кода копирования и вставки на производстве. Если я хочу скопировать ячейки из источника в пункт назначения, то я использую массив/набор данных Range.Value2. Таким образом, пример может быть

Range("Destination").Value2 = Range("Source").Value2 

Вам необходимо убедиться, что диапазоны источника и назначения имеют одинаковую размерность. Поэтому замените этот тип кода на ваши значения для копирования и вставки. Кроме того, форматируйте ячейки с кодом VBA, а не копируйте из буфера обмена.

Посмотрите, исправит ли это. Отправить отзыв.

Answer 2

@S Meaden является правильным в отношении того, что вы должны стараться избегать .Copy + .Paste, когда это возможно.

Однако, поскольку вы хотите использовать форматы, я думаю, это на самом деле один из редких случаев, когда копирование + вставка имеет смысл.

Я рассматриваю вашу проблему не как .Copy как таковой, а скорее повторяющийся .Open + .Close книг OnePager.

Когда я столкнулся с аналогичной проблемой, мой Excel точно не сработал, макрос просто остановился случайным образом, не запуская обработчик ошибок.

Я хотел бы попробовать следующее:

• открыть новый Excel перед входом в петлю
• открыть ваши OnePager-файлы с этим приложением, и вставить в существующий Excel

Надежда, что помогает!

Вот как вы можете настроить свой код:

Private Sub GenerateReportOP() 

    '... your code 

    ' open a new Excel in which you open the files 
    Dim xlApp As New Excel.Application 
    i = 3 
    Do While i <= LastRowMOP 

     '... your code 

     ' change: repeatedly open the files in your new excel app 
     Set OnePager = xlApp.Workbooks.Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 

     '... your code 

     xlApp.CutCopyMode = False 
     OnePager.Close savechanges:=False 

     '... your code 

    i = i + 1 
    Loop 

    ' close the new excel after you're done looping. always close it (w/ errorhandler), so you dont have to shut it down with the task manager 
    xlApp.Quit 
    Set xlApp = Nothing 

    '... your code 

    MsgBox "Finished. Please check ""One Pagers"" tab." 
End Sub 

Кроме того, чтение this должен ускорить ваше кодирование совсем немного, вероятно, сделает ваш код более читаемым

Answer 3

Спасибо всем за вашу помощь. Я объединил два совета Даррена и S Maeden. Я изменил свой обработчик ошибок и сделал макрос, чтобы скопировать данные прямо в ячейки, избегая использования буфера обмена. Я просто работаю на верстку части в настоящее время

OPPath = ThisMacro.Range("B" & i) & ThisMacro.Range("F1") & "\" & ThisMacro.Range("H1") & "\" 
     'error handler if path is not correct 
     On Error Resume Next 
     Set OnePager = Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 
     If Err.Number = 1004 Then 
      If ThisOnePage.Range("D" & LastRow1 + 1) = "" Then 
       ThisOnePage.Range("C" & LastRow1 + 1).Value = "Unable to find One Pager, please check file or path!" 
      End If 
     Else 
      Set OnePagerWS = OnePager.Worksheets("Check list") 
      LastRow2 = OnePagerWS.Range("A" & Rows.Count).End(xlUp).Row 
      LastRowZ = OnePagerWS.Range("Z" & Rows.Count).End(xlUp).Row 
      'check what rates is linked 
      Rates = OnePagerWS.Range("S9").Formula 
      SubstrinLoc = InStr(1, Rates, "FY") 
      ThisOnePage.Range("D" & LastRow1 + 1) = Mid(Rates, SubstrinLoc + 6, 13) 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Bold = True 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Color = vbBlue 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Size = 14 
      'copy one pager 
      ThisOnePage.Range("I" & LastRow1 + 2).Value = OnePagerWS.Range("D4").Value 

      ThisOnePage.Range("B" & LastRow1 + 2 & ":B" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("A6:A" & LastRow2).Value 

      ThisOnePage.Range("C" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("J6:J" & LastRow2).Value 
      ThisOnePage.Range("C" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).NumberFormat = "0" 
      ThisOnePage.Range("D" & LastRow1 + 2 & ":D" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("L6:L" & LastRow2).Value 
      ThisOnePage.Range("D" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).NumberFormat = "0" 
      ThisOnePage.Range("E" & LastRow1 + 2 & ":E" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("N6:N" & LastRow2).Value 

      ThisOnePage.Range("F" & LastRow1 + 2 & ":F" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("Q6:Q" & LastRow2).Value 

      ThisOnePage.Range("G" & LastRow1 + 2 & ":G" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("S6:S" & LastRow2).Value 

      ThisOnePage.Range("H" & LastRow1 + 2).Value = OnePagerWS.Range("T6:T" & LastRow2).Value 

      ThisOnePage.Range("J" & LastRow1 + 2).Value = OnePagerWS.Range("Z" & LastRowZ).Value 

      LastRow2 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
      With ThisOnePage 
       .Range(.Cells(LastRow1 + 4, 1), .Cells(LastRow2, 1)) = ThisMacro.Range("A" & i) 
      End With 
      Application.CutCopyMode = False 
      OnePager.Close savechanges:=False 
     End If 
    End If 

    i = i + 1 
    Loop