合并多个工作簿的宏，使用excel 2010，但不使用2016

我有一个宏，可以将多个工作簿合并到单个合并文件中。最初它是一个复制和粘贴，但我改变了它，认为复制和粘贴对计算机来说太重，导致它崩溃。成功实施更改后，在循环执行第50个工作簿后，宏继续失败。非常感谢您能深入了解我的excel使用此宏崩溃（关闭和打开）的原因

注意：此宏在使用excel 2010的对等计算机上工作

Dim TargetFolder As String, TargetFile As String
Dim wsConsol As Worksheet
Dim CopyLastRow As Long, DestLastRow As Long
Dim TranRange As Variant

'Sets the name of the wsConsol file, if required
Set wsConsol = Workbooks("Consolidation File.xlsm").Worksheets("Raw Data")

'Opens a file dialog box for user to select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .Show
   TargetFolder = .SelectedItems(1)
   Err.Clear
End With

'stops screen updating, calculations, events, and status bar updates to help code run faster
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.CutCopyMode = False

'This section will loop through and open each file in the folder you selected
'and then close that file before opening the next file

TargetFile = Dir(TargetFolder & "\", vbReadOnly)

Do While TargetFile <> ""
    DoEvents
    On Error GoTo 0
    Workbooks.Open Filename:=TargetFolder & "\" & TargetFile, UpdateLinks:=False

             ''''''''''''START CODE HERE TO DO SOMETHING'''''''''

    'Find the last row in the wsConsol file
    DestLastRow = wsConsol.Cells(wsConsol.Rows.Count, "A").End(xlUp).Offset(1).Row


    wsConsol.Range("A" & DestLastRow).Value = Workbooks(TargetFile).Worksheets("Summary").Range("B22:B22").Value


    wsConsol.Range("AD" & DestLastRow).Value = Workbooks(TargetFile).Worksheets("Summary").Range("B17:B17").Value


    wsConsol.Range("B" & DestLastRow).Value = Workbooks(TargetFile).Worksheets("Summary").Range("B20:B20").Value



    TranRange = Workbooks(TargetFile).Worksheets("Summary").Range("D25:L25").Value
    TranRange = Application.WorksheetFunction.Transpose(TranRange)
    wsConsol.Range("C" & DestLastRow & ":K" & DestLastRow).Value = TranRange


    TranRange = Workbooks(TargetFile).Worksheets("Summary").Range("F17:F22").Value
    TranRange = Application.WorksheetFunction.Transpose(TranRange)
    wsConsol.Range("L" & DestLastRow & ":Q" & DestLastRow).Value = TranRange


    TranRange = Workbooks(TargetFile).Worksheets("Summary").Range("G17:G22").Value
    TranRange = Application.WorksheetFunction.Transpose(TranRange)
    wsConsol.Range("R" & DestLastRow & ":W" & DestLastRow).Value = TranRange


    TranRange = Workbooks(TargetFile).Worksheets("Summary").Range("H17:H22").Value
    TranRange = Application.WorksheetFunction.Transpose(TranRange)
    wsConsol.Range("X" & DestLastRow & ":AD" & DestLastRow).Value = TranRange

    ''''''''''''END CODE HERE THAT DID SOMETHING'''''''''

    'Close TargetFile Workbook
    Workbooks(TargetFile).Close SaveChanges:=False
    TargetFile = Dir
Loop

'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual

End Sub

Dim TargetFolder作为字符串，TargetFile作为字符串
将WSConsole设置为工作表
将CopyLastRow变长，将DestLastRow变长
作为变量的范围
'设置WSConsole文件的名称（如果需要）
设置wsConsol=工作簿（“合并文件.xlsm”）。工作表（“原始数据”）
'打开一个文件对话框，供用户选择文件夹
使用Application.FileDialog（msoFileDialogFolderPicker）
.AllowMultiSelect=False
显示
TargetFolder=.SelectedItems（1）
呃，明白了
以
'停止屏幕更新、计算、事件和状态栏更新，以帮助代码更快地运行
Application.ScreenUpdating=True
Application.DisplayStatusBar=True
Application.EnableEvents=False
Application.Calculation=xlCalculationManual
Application.CutCopyMode=False
'此部分将循环浏览并打开选定文件夹中的每个文件
'然后在打开下一个文件之前关闭该文件
TargetFile=Dir（TargetFolder&“\”，vbReadOnly）
当目标文件“”时执行此操作
多芬特
错误转到0
工作簿。打开文件名：=TargetFolder&“\”&TargetFile，更新链接：=False
从这里开始编码做点什么
'查找WSConsole文件中的最后一行
DestLastRow=wsConsol.Cells（wsConsol.Rows.Count，“A”）.End（xlUp）.Offset（1）.Row
wsConsol.Range（“A”和DestLastRow）.Value=工作簿（TargetFile）.Worksheets（“Summary”）.Range（“B22:B22”）.Value
wsConsol.Range（“AD”和DestLastRow）.Value=工作簿（TargetFile）.Worksheets（“Summary”）.Range（“B17:B17”）.Value
wsConsol.Range（“B”和DestLastRow）.Value=工作簿（TargetFile）.Worksheets（“摘要”）.Range（“B20:B20”）.Value
TranRange=工作簿（TargetFile）.Worksheets（“摘要”）.Range（“D25:L25”）.Value
TranRange=Application.WorksheetFunction.Transpose（TranRange）
wsConsol.Range（“C”&DestLastRow&“：K”&DestLastRow）.Value=TranRange
TranRange=工作簿（TargetFile）.Worksheets（“摘要”）.Range（“F17:F22”）.Value
TranRange=Application.WorksheetFunction.Transpose（TranRange）
wsConsol.Range（“L”&DestLastRow&“：Q”&DestLastRow）.Value=TranRange
TranRange=工作簿（TargetFile）.Worksheets（“摘要”）.Range（“G17:G22”）.Value
TranRange=Application.WorksheetFunction.Transpose（TranRange）
wsConsol.Range（“R”&DestLastRow&“：W”&DestLastRow）。Value=TranRange
TranRange=工作簿（TargetFile）.Worksheets（“摘要”）.Range（“H17:H22”）.Value
TranRange=Application.WorksheetFunction.Transpose（TranRange）
wsConsol.Range（“X”&DestLastRow&“：AD”&DestLastRow）。Value=TranRange
这里的结束码做了些什么
'关闭目标文件工作簿
工作簿（目标文件）。关闭保存更改：=False
TargetFile=Dir
环
'将在循环文件夹之前关闭的设置重新打开
Application.ScreenUpdating=True
Application.DisplayStatusBar=True
Application.EnableEvents=True
Application.Calculation=xlCalculationManual
端接头

您是否使用与同事相同的文件夹？我曾经遇到过类似的问题，并发现在同一本书上它总是失败。当我仅在那本书上运行宏时，我发现特定工作簿已损坏并导致崩溃。在排除了那本书之后，他工作得很好。不知道这是否是问题所在，但可能值得检查。使用Excel 2016中的本机软件可以更有效地处理此任务。我读过关于这个问题的文章，其中很多都是关于解决方法的。@Warcupine是的，我使用的是同一个源文件夹。他可以将文件夹移动到他的桌面或在我们的驱动器上访问它，并且无论何时都可以工作him@urdearboy它总是围绕着同一个文件失败，所以我可能会进一步调查。