我需要將 2,700 個作業簿中的兩個作業表中的資料合并到 1 個大作業簿中的兩個作業表中。我有一段代碼運行良好，但經過不同數量的回圈后，它完全崩潰了。有時它可能會通過 10 個檔案，其他可能會通過 40 個左右，以及介于兩者之間的所有數字。
我在 excel 中沒有收到任何錯誤訊息，也無法追蹤導致崩潰的原因。Excel 只是崩潰，就好像它從任務管理器中終止一樣。
我的代碼充其量只是新手級別，對于任何不正確的結構/語法/注釋，請接受我的歉意。我已經包含了 sub 和在其中呼叫的函式以確定作業表是否存在
您能否查看此代碼，看看是否有問題導致了問題？謝謝！
Sub SheetCopier()
Dim wb As Workbook
Dim tbl As ListObject
Dim CurrentFile As Variant
Dim LoadRows As Double
Dim AuditRows As Double
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Path = "C:\Desktop\FileList\"
Set tbl = Worksheets("FileList").ListObjects("FileList") 'table spring all of the files to loop through
counter = 2 'starts the counter so the file list can be updated for progress
For Each CurrentFile In tbl.ListColumns("Name").DataBodyRange
LoadRows = 0
AuditRows = 0
Set wb = Application.Workbooks.Open(Filename:=Path & CurrentFile, UpdateLinks:=False) 'opens the data file
'Copies data from the LOAD sheet
If SheetExists(wb, "LOAD") Then 'calls the SheetExists function to determine if the sheet exists
wb.Sheets("LOAD").Select
Range("A1").Select
If Range("A1").Value <> "" And Range("A2").Value <> "" Then 'if there is actual information in the load sheet
Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Select 'select all cells in the load sheet except for the header row
LoadRows = Selection.Rows.Count 'count how many rows there are
Range("S2:S" & LoadRows 1).Value = CurrentFile 'appends the filename to the rows that are being copied
Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Copy 'copy the rows
ThisWorkbook.Activate 'come back to the main workbook
Sheets("LOAD").Select 'go to the LOAD sheet in the main workbook
Range("A1").Select 'go to this workbooks load sheet
Cells(Range("A2").SpecialCells(xlLastCell).Row 1, 1).Select 'go to the last row on the load sheet
ActiveSheet.Paste 'paste the data
tbl.Range.Cells(counter, 3) = LoadRows 'mark the number of rows copied on the file list
End If
End If
wb.Activate 'go back to the target file to copy from
'Copeis data from the AUDIT RESULTS sheet
If SheetExists(wb, "AUDIT RESULTS") = True Then
wb.Sheets("AUDIT RESULTS").Select
Range("A1").Select
If Range("A1").Value <> "" And Range("A2").Value <> "" Then 'if there is actual information in the audit sheet
Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Select 'select all cells in the load sheet
AuditRows = Selection.Rows.Count 'count how many rows there are
Range("AA2:AA" & AuditRows 1).Value = CurrentFile 'appends the filename to the rows that are being copied
Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Copy 'copy the rows
ThisWorkbook.Activate 'come back to this workbook
Sheets("AUDIT RESULTS").Select
Range("A1").Select 'go to this workbooks load sheet
Cells(Range("A2").SpecialCells(xlLastCell).Row 1, 1).Select 'go to the last row on the load sheet
ActiveSheet.Paste 'paste the data
tbl.Range.Cells(counter, 4) = AuditRows 'mark the number of rows copied
End If
End If
wb.Close SaveChanges:=False 'close the target file
Set wb = Nothing
If counter Mod 10 = 0 Then ThisWorkbook.Save 'save the main file every 10 loops (because of the crashes)
counter = counter 1
Next
Set tbl = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function SheetExists(wb As Workbook, strSheetName As String) As Boolean
Dim wks As Worksheet
For Each wks In wb.Worksheets
If wks.Name = strSheetName Then
SheetExists = True
Exit Function
End If
Next
SheetExists = False
End Function
嘗試更改回圈的各個方面，結果相同
uj5u.com熱心網友回復：
避免 Active/Select，并將通用代碼重構為單獨的函式：
Sub SheetCopier()
Const FILE_PATH As String = "C:\Desktop\FileList\" 'use const for fixed values
Dim wb As Workbook, tbl As ListObject
Dim CurrentFile As Range, wsLoad As Worksheet, wsAudit As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wsLoad = ThisWorkbook.Worksheets("LOAD")
Set wsAudit = ThisWorkbook.Worksheets("AUDIT RESULTS")
Set tbl = ThisWorkbook.Worksheets("FileList").ListObjects("FileList")
For Each CurrentFile In tbl.ListColumns("Name").DataBodyRange.Cells
Set wb = Application.Workbooks.Open(Filename:=FILE_PATH & CurrentFile.Value, _
ReadOnly:=True, UpdateLinks:=False)
tbl.Range.Cells(CurrentFile.Row, 3) = CopyData(wb, "LOAD", "S", _
wsLoad.Range("A2").SpecialCells(xlLastCell).EntireRow.Columns("A").Offset(1))
tbl.Range.Cells(CurrentFile.Row, 4) = CopyData(wb, "AUDIT RESULTS", "AA", _
wsAudit.Range("A2").SpecialCells(xlLastCell).EntireRow.Columns("A").Offset(1))
wb.Close SaveChanges:=False
If CurrentFile.Row Mod 10 = 0 Then ThisWorkbook.Save
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'Copy data from worksheet `srcWsName` in workbook `srcWb` (if it exists) to cell `destCell`
' Insert the source workbook filename in the column `fNameCol` before copying
Function CopyData(srcWB As Workbook, srcWsName As String, _
fNameCol As String, destCell As Range) As Long
Dim ws As Worksheet, rngCopy As Range
On Error Resume Next 'ignore error if sheet doesn't exist
Set ws = srcWB.Worksheets(srcWsName)
On Error GoTo 0 'stop ignoring errors
If Not ws Is Nothing Then
If Application.CountA(ws.Range("A1:A2")) = 2 Then
With ws.Range("A2", ws.Range("A2").SpecialCells(xlLastCell))
CopyData = .Rows.Count 'return # of rows copied
.EntireRow.Columns(fNameCol).Value = srcWB.Name 'fill in the file name
.Copy destCell 'copy the data
End With
End If
End If
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/525171.html
標籤：擅长vba循环碰撞
上一篇：如何對3d陣列中的每個陣列求和