编写VBA代码批量打开工作簿并复制指定工作表报错及解决

我尝试编写VBA代码，实现逐个打开指定路径下的工作簿，并将其中特定工作表复制到目标工作簿。运行初始代码时，打开第一个文件就触发“method or data member not found”错误；修改代码后又出现“Run-time error'-2147221080 (800401a8)': Automation error”，最终调试出可用版本，各阶段代码如下：

初始代码（触发“method or data member not found”错误） #

Sub OpenFilesMoveCopyWorksheet()
    Const PTH As String = "C:\Users\xxx\yyy\" 'use const for fixed values
    
    Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
    Dim SFlname As String, I As Long, DFile As Workbook
    Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
    
    Set SFile = ThisWorkbook
    Set SFname = SFile.Worksheets("Sheet1")
    
    Application.ScreenUpdating = False
    
    For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row

        SFlname = SFname.Range("A" & I).Value
        If Len(SFlname) > 0 Then

            Set DFile = Workbooks.Open(PTH & SFlname)
              
            If DFile.Worksheets.Name Like "*.cours" Then
            
            DFile.Worksheet.copyafter: SFile.SFname
                                
            End If
            DFile.Close savechanges:=False
        End If
    Next I
    
    MsgBox "job done"
    Application.ScreenUpdating = True
End Sub

修改后代码（触发“Run-time error'-2147221080 (800401a8)': Automation error”错误） #

Sub OpenFilesMoveCopyPaste()
    Const PTH As String = "C:\xxx\yy\" 'use const for fixed values

    Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
    Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
    Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range

    Set SFile = ThisWorkbook
    Set SFname = SFile.Worksheets("Sheet1")

    Application.ScreenUpdating = False

    For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row

        SFlname = SFname.Range("A" & I).Value
        
        If Len(SFlname) > 0 Then

            Set DFile = Workbooks.Open(PTH & SFlname)
              
            For I1 = 1 To SFname.Cells(Rows.Count, "B").End(xlUp).Row
            
                SFlname2 = SFname.Range("B" & I1).Value
                
                If Len(SFlname2) > 0 Then
                
                    Set ws = DFile.Worksheets(SFlname2)
                    
                    ws.Copy Before:=SFile.Sheets("sheet1")
                    
                    
                    DFile.Close savechanges:=False
                End If
            Next I1
        End If
    Next I

    MsgBox "job done"
    Application.ScreenUpdating = True
End Sub

最终可用版本 #

Sub OpenFilesMoveCopyPasteSpecial()
    Const PTH As String = "C:\XXX\YY\" 'use const for fixed values

    Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
    Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
    Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range

    Application.DisplayAlerts = False

    Set SFile = ThisWorkbook
    Set SFname = SFile.Worksheets("Sheet1")

    Application.ScreenUpdating = False

    For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row

        SFlname = SFname.Range("A" & I).Value
        
        If Len(SFlname) > 0 Then

            Set DFile = Workbooks.Open(PTH & SFlname)
            
            Debug.Print DFile.Name
              
            SFlname2 = SFname.Range("B" & I).Value
            
            Set ws = DFile.Worksheets(SFlname2)
            
            ws.Copy After:=SFile.Sheets("sheet1")
            
            
            Cells.Select
            Range("AO1").Activate
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Application.CutCopyMode = False
            
                  
            DFile.Close savechanges:=False
        End If
    Next I

    MsgBox "job done"
    Application.ScreenUpdating = True

    Application.DisplayAlerts = True
End Sub

内容的提问来源于stack exchange，提问作者deepankar haldar