vba - Excel 在循环中进行简单 VBA(打开文件、复制、粘贴、关闭)期间崩溃

Question

我是一名新的 Excel 2013 vba 程序员。我编写了代码来循环访问文件夹中的每个文件，打开它，复制单元格，然后粘贴到新文件，向下递增一行，并对文件夹中的每个文件执行此操作。

在循环到下一个文件之前，我会关闭前一个文件。该文件夹内约有120个文件。这最终是为了在单个文件中创建文件夹中数据的索引。

当我“单步执行”时，这似乎运行良好，但如果我只是 F5 宏，它会运行一段时间，我会看到它工作正常，然后在执行过程中崩溃 Excel“Excel 已停止工作... “它就关闭了。

您以前遇到过这种情况吗？有什么建议么？以下是完成该工作的代码子集:

Sub WorkHorse()
    ' Application.DisplayAlerts = False 'large amount of data in clipboard, do you want to keep..." message_ *MUST TURN BACK ON SEE BELOW!!

    ChDir "R:\ISO\Sticks\307M"
    myFile = Dir("*.xlsx")


    Do Until myFile = ""
        Workbooks.Open Filename:=myFile
        If Range("A3") = "" Then
            Range("A2").Select
            Range(Selection, Selection.End(xlToRight)).Select
        End If
        If Range("A3") <> "" Then
            Range("A2").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
        End If
        Selection.Copy
        Windows("Test for Possanza Aug 2015.xlsm").Activate
        ActiveSheet.Paste
        Range("A1").Select
        ActiveSheet.Range("A1").Copy
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Range("a1").Select
        Windows(myFile).Close
        myFile = Dir
    Loop

    ' Application.DisplayAlerts = True 'this re-enables Display Alerts in MSOffice. *CRITICAL TO TURN BACK ON!

End Sub

大家好，感谢您的帮助。请随时就如何添加带有附加评论/问题的新代码向我提出建议——这对我来说是新的。
根据我下面的评论和您的建议，我修改了代码。我还没有尝试使用 Davesexcel 的修复程序，但是当昨天它不起作用时，我做了一些挖掘，发现一个 CurrentRegion 命令似乎可以工作，除了它包含每个被复制的文件的标题行(第 1 行)。我发现的信息说它假设一个标题行并且不包含它，但这似乎没有发生。这是我的新代码，非常感谢建议。另外，注释行——为什么这不起作用？它出错了。根据您向我指出的建议，我试图具体说明工作簿和工作表(始终是工作簿中的第一个工作表，但名称有所不同)。谢谢。

   Sub ReDoWorkHorseWithoutSelect()
    Dim myfile As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim DataBlock As Range

    Set wb = Workbooks("Test for Possanza Aug 2015.xlsm")
    Set ws = wb.Sheets("Sheet1")    'change desired sheet

    ChDir "R:\ISO\Sticks\307M"
    myfile = Dir("*.xlsx")

    Do Until myfile = ""
        Workbooks.Open Filename:=myfile
'       Set DataBlock = Workbooks("myfile").Worksheets(1).Range("A1").CurrentRegion
        Set DataBlock = Range("A2").CurrentRegion
        DataBlock.Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
        Windows(myfile).Close
        myfile = Dir
    Loop

Answer 1

可能是多个选择，或选择的范围。

像这样的东西怎么样，这样你就不必使用选择

Dim wb As Workbook, ws As Worksheet
Dim rng2 As Range
Dim Crng As Range


Set wb = Workbooks("Test for Possanza Aug 2015.xlsm")
Set ws = wb.Sheets("Sheet1")    'change desired sheet

'other code


Do Until myFile = ""
    Workbooks.Open Filename:=myFile
    Set rng2 = Range("A2")
    If rng2 = "" Then
        Set Crng = Range(rng2, rng2.End(xlToRight))
    Else
        r = Cells(Rows.Count, "A").End(xlUp).Row
        c = Cells(2, Columns.Count).End(xlToRight).Column
        Set Crng = Range(Cells(2, 1), Cells(r, c))
    End If

    Crng.Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)


    Windows(myFile).Close
    myFile = Dir
Loop

可能的用途

myfile.close true

那么您就不必担心“显示警报”，但您必须对其进行测试。