Option Explicit
Sub CombineFiles()
Dim path As String
Dim Filename As String
Dim Wkb As Workbook
Dim ws As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
path = "C:UsersAbinsDesktopPayment Posting VBA 19062022Consol" 'Change as needed
Filename = Dir(path & "*.xls", vbNormal)
Do Until Filename = ""
Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
For Each ws In Wkb.Worksheets
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next ws
Wkb.Close False
Filename = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Success! Press Cntrl+J"
End Sub
我想找到一个解决方案，因为这个代码被用来从包含超过80个excel工作簿，每个有三个工作表的文件夹组合多个文件。它在我的系统上运行良好(在我的个人笔记本电脑、办公系统和一个同事的系统上)。
感谢您的帮助
Thanks in advance
导入工作表
- 看起来文件夹中没有文件，除非您的同事在代码中添加了
On Error Resume Next，这时可能存在以下过程中涉及的任何问题。试一试，分享一些反馈。 - 请注意，你的程序没有任何问题。
Sub CombineFiles()
Const ProcName As String = "CombineFiles"
Dim ErrNumber As Long
Dim ErrDescription As String
Dim swbCount As Long
Dim swsCount As Long
Dim swsCountTotal As Long
Dim IsSuccess As Boolean
On Error GoTo ClearError
Const FOLDER_PATH As String = "C:Test"
Const USE_DESKTOP As Boolean = True
Const DESKTOP_RELATIVE_PATH As String _
= "Payment Posting VBA 19062022Consol"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
Dim pSep As String: pSep = Application.PathSeparator
' Build the source folder path.
Dim SourceFolderPath As String
If USE_DESKTOP Then
' Get the Desktop path.
Dim DesktopPath As String
DesktopPath = Environ("USERPROFILE") & pSep & "Desktop" & pSep
Dim DesktopName As String
DesktopName = Dir(DesktopPath, vbDirectory)
If Len(DesktopName) = 0 Then
DesktopPath = Environ("OneDrive") & pSep & "Desktop" & pSep
DesktopName = Dir(DesktopPath, vbDirectory)
If Len(DesktopName) = 0 Then
MsgBox "Could not find the Desktop path.", vbCritical, ProcName
Exit Sub
End If
End If
SourceFolderPath = DesktopPath & DESKTOP_RELATIVE_PATH
Else ' don't use Desktop relative path
SourceFolderPath = FOLDER_PATH
End If
If Right(SourceFolderPath, 1) <> pSep Then
SourceFolderPath = SourceFolderPath & pSep
End If
Dim SourceFolderName As String
SourceFolderName = Dir(SourceFolderPath, vbDirectory)
If Len(SourceFolderName) = 0 Then
MsgBox "The path '" & SourceFolderPath & "' doesn't exist.", _
vbExclamation, ProcName
Exit Sub
End If
' Build the Dir pattern.
Dim DirPattern As String
DirPattern = SourceFolderPath & SOURCE_FILE_PATTERN
' Get the first file name.
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found matching the pattern '" & SOURCE_FILE_PATTERN _
& "' in '" & SourceFolderPath & "'.", _
vbExclamation, ProcName
Exit Sub
End If
' Reference the destination workbook.
Dim dwb As Workbook: Set dwb = ThisWorkbook
' Open, copy & close.
Dim swb As Workbook
Dim sws As Worksheet
Dim SourceFilePath As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Do While Len(SourceFileName) > 0
SourceFilePath = SourceFolderPath & SourceFileName
Set swb = Workbooks.Open(SourceFilePath, True, True)
swbCount = swbCount + 1
swsCountTotal = swsCountTotal + swb.Worksheets.Count
For Each sws In swb.Worksheets
If Not sws.Visible = xlSheetVeryHidden Then
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
swsCount = swsCount + 1
'Else ' it's very hidden; do nothing!?
End If
Next sws
swb.Close SaveChanges:=False
SourceFileName = Dir
Loop
IsSuccess = True
ProcExit:
On Error Resume Next
If Not Application.EnableEvents Then Application.EnableEvents = True
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Dim CountMsg As String:
CountMsg = vbLf & vbLf & "Workbooks processed: " & swbCount & vbLf _
& "Worksheets copied: " & swsCount & "(" & swsCountTotal & ")"
If IsSuccess Then
MsgBox "Success! Press Ctrl+J" & CountMsg, vbInformation, ProcName
Else
MsgBox "Run-time error '" & ErrNumber & "':" _
& vbLf & ErrDescription & CountMsg, vbCritical, ProcName
End If
On Error GoTo 0
Exit Sub
ClearError:
ErrNumber = Err.Number
ErrDescription = Err.Description
Resume ProcExit
End Sub