Question

我创建了一个宏，可以打开几个文件并将这些文件中的数据复制到一个工作簿中。宏的工作方式是： 1）有一个主工作簿（目标工作簿），工作表很少，其中一个工作表包含列B中文件的路径。单元格F1和H1包含两个用户指定的子文件夹，这两个单元格被添加到文件路径中。文件名称不同，但所有文件都包含＆＃34; One pager＆＃34;在名字里。所以我使用文件路径和通配符＆＃34; One pager *＆＃34; ＆安培; ＆＃34; .XLSX＆＃34;打开文件。 2）宏检查路径填充的行数，并在路径中循环，打开每个文件（源工作簿），将指定的字段复制到主工作簿中的目标工作表中，然后关闭源文件。

当我逐步运行它或者我设置一个断点并且一次运行一个循环时，宏工作正常，但是一旦我运行完整的宏，我的Excel在运行5-6个文件后崩溃。我尝试在4台不同的计算机上运行相同的宏，其中两台运行宏时崩溃崩溃，其中两台宏工作正常。两台计算机崩溃运行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，而是OnePager工作簿的重复.Open + .Close。

当我遇到类似的问题时，我的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

谢谢大家的帮助。我结合了Darren和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

运行循环遍历多个文件的宏时，Excel崩溃

3 个答案: