导入工作表

• 除非您的同事在代码中添加了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 19062022\Consol"
    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