excel 这段代码在我的系统中运行成功,但是当我尝试在其他系统中运行时,它不起作用

4jb9z9bj  于 2022-11-18  发布在  其他
关注(0)|答案(1)|浏览(131)
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:\Users\Abins\Desktop\Payment Posting VBA 19062022\Consol" '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工作簿,每个有三个工作表的文件夹中合并多个文件。它在我的系统上工作正常(在我的个人笔记本电脑,办公系统,和一个同事的系统)。
任何帮助都是感激不尽的
先谢了

mzsu5hc0

mzsu5hc01#

导入工作表

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

相关问题