0
我创建了一个宏，该宏打开几个文件并将该文件中的数据复制到一个工作簿中。宏的工作方式是： 1）有一个主要工作簿（目标工作簿）和少量工作表，其中一个工作表包含B列中文件的路径。单元格F1和H1包含两个子文件夹，用户可以指定这两个单元格被添加到文件路径中。文件的命名方式不同，但名称中包含“One pager”。所以我使用文件路径和通配符“One pager *”&“.xlsx”来打开文件。 2）宏检查有多少行填充路径，并循环遍历具有路径的行，打开每个文件（源工作簿），将指定的字段复制到主工作簿中的目标工作表中，然后关闭源文件。运行通过几个文件循环的宏时，Excel崩溃
宏工作正常，当我运行它一步一步或者当我设置一个断点，并一次运行一个循环，但只要我通过5-6文件运行后运行完整的宏我的Excel崩溃。我试图在4台不同的计算机上运行同一个宏，其中两台运行宏时出现了excel崩溃，其中两台宏运行正常。两台电脑宏运行崩溃运行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
可能不是问题，但你的错误处理程序代码应该是过程的主体之外 - 退出Sub'之间'和'结束Sub' –