在文件夹中打开 excel 工作簿以复制特定工作表时出现运行时错误 9

Question

我需要帮助来处理运行时错误 9。我的目标是创建一个新工作簿，该工作簿从文件夹中的所有 excel 工作簿编译特定工作表（主用户）。 我在使用“on error goto”时被卡住了，因为我不知道如何在错误（工作表不存在）转到下一个工作簿时设置程序。 我的代码现在导致我陷入没有“主用户”工作表的工作簿的永无止境的循环

Sub Master()
    Dim MyFiles As String
    Dim Path As String
    Dim myExtension As String
    Dim Filename As String
    
    Workbooks.Add.SaveAs Filename:="Master", FileFormat:=51
    Path = "D:\My Document\"
    myExtension = "*.xls*"
    MyFiles = Dir(Path & myExtension)
    
    On Error GoTo test

DoAgain:
    Do While MyFiles <> ""
    Workbooks.Open (Path & MyFiles)
      Sheets("master user").Select
      ActiveSheet.Rows(1).Copy
      Workbooks("Master.xlsx").Activate
      Sheets.Add After:=Sheets(Sheets.Count)
      Range("A1").PasteSpecial xlPasteAll
      If InStr(MyFiles, ".") > 0 Then
   Filename = Left(MyFiles, InStr(MyFiles, ".") - 1)
End If
      ActiveSheet.Name = Filename
      Workbooks(Filename).Activate
      Application.CutCopyMode = False
      ActiveWorkbook.Close SaveChanges:=False
    MyFiles = Dir
    Loop
      Workbooks("Master.xlsx").Activate
      ActiveWorkbook.Close SaveChanges:=True

test:
      ActiveWorkbook.Close SaveChanges:=False
Resume DoAgain

ActiveWorkbook.Save
End Sub

Answer 1

将工作表范围从多个工作簿复制到新工作簿

工作簿

1. 包含此代码的工作簿 ( ThisWorkbook )。
2. 源工作簿，即在源文件夹中找到的每个工作簿（文件）。
3. 目标工作簿，即将复制到的新添加的工作簿。

描述

• 这会将文件夹中找到的每个工作簿（文件）的同名工作表的第一行复制到新工作簿（一个）的新添加（和重命名）工作表（多个）。

Option Explicit

Sub CreateMaster()
    Const ProcName As String = "CreateMaster"
    On Error GoTo ClearError
    
    ' Source
    Const sFolderPath As String = "D:\My Document\" ' maybe a missing 's'?
    Const sFilePattern As String = "*"
    Const sExtensionPattern As String = ".xls*"
    Const swsName As String = "Master User"
    ' Destination
    Const dFileName As String = "Master.xlsx"
    ' You never mentioned the destination path ('Master.xlsx') so I chose
    ' the same path as the path of the workbook containing this code.
    ' Omitting this path will lead to unexpected results (errors).
    Dim dFilePath As String: dFilePath = ThisWorkbook.Path & "\"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    
    ' Check if the source folder exists.
    If Len(Dir(sFolderPath, vbDirectory)) = 0 Then
        MsgBox "The folder '" & sFolderPath & "' doesn't exist.", _
            vbCritical, ProcName
        Exit Sub
    End If
    
    ' Return the paths of the files of the source folder in a collection.
    Dim sFilePaths As Collection
    Set sFilePaths = CollFilePaths(sFolderPath, sFilePattern, sExtensionPattern)
    If sFilePaths Is Nothing Then ' no files found
        MsgBox "No '" & sExtensionPattern & "'- files found in folder '" _
            & sFolderPath & "'.", vbCritical, ProcName
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim sFilePath As Variant
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dwbCreated As Boolean
    
    ' Loop through the elements (file paths) of the collection.
    For Each sFilePath In sFilePaths
        Set swb = Workbooks.Open(sFilePath)
        ' Attempt to create a reference to the source worksheet.
        On Error Resume Next
            Set sws = swb.Worksheets(swsName)
        On Error GoTo ClearError
        If Not sws Is Nothing Then ' source worksheet exists
            ' Add a new worksheet/workbook.
            If dwbCreated Then ' destination workbook created
                Set dws = dwb.Worksheets _
                    .Add(After:=dwb.Sheets(dwb.Sheets.Count))
            Else ' destination workbook not created
                Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
                Set dws = dwb.Worksheets(1)
                dwbCreated = True
            End If
            ' Attempt to rename the destination worksheet.
            On Error Resume Next
                dws.Name = Left(swb.Name, InStrRev(swb.Name, ".") - 1)
            On Error GoTo ClearError
            ' Copy source to destination.
            sws.Rows(1).Copy dws.Rows(1)
        'Else ' source worksheet doesn't exist
        End If
        swb.Close SaveChanges:=False
    Next sFilePath
    
    If dwbCreated Then
        dwb.Worksheets(1).Activate
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath & dFileName, dFileFormat
        Application.DisplayAlerts = True
        dwb.Close
        MsgBox "Master created.", vbInformation, ProcName
    Else
        MsgBox "Non of the opened workbooks contained a worksheet " _
            & "named '" & swsName & "'.", vbExclamation, ProcName
    End If
    
    Application.ScreenUpdating = False
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the paths of the files of a folder in a collection.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*", _
    Optional ByVal ExtensionPattern As String = "*") _
As Collection
    Const ProcName As String = "CollFilePaths"
    On Error GoTo ClearError
    
    Dim pSep As String: pSep = Application.PathSeparator
    Dim foPath As String: foPath = FolderPath
    If Right(foPath, 1) <> pSep Then foPath = foPath & pSep
    
    Dim ePattern As String: ePattern = ExtensionPattern
    If Left(ePattern, 1) <> "." Then ePattern = "." & ePattern
    
    Dim fiName As String: fiName = Dir(foPath & FilePattern & ePattern)
    If Len(fiName) = 0 Then Exit Function
        
    Dim coll As Collection: Set coll = New Collection
    
    Do Until Len(fiName) = 0
        coll.Add foPath & fiName
        fiName = Dir
    Loop
    
    Set CollFilePaths = coll
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function