Kopieren Sie alle Blätter aus einer Zielarbeitsmappe

Question

Ich bekomme Laufzeitfehler '2147 und für das Leben von mir kann ich nicht sehen, was ich vermisse.

Alles, was ich versuche zu tun, ist von meinem aktuellen workook öffnen Sie eine ausgewählte Arbeitsmappe und kopieren Sie in allen Blättern.

Vielen Dank.

Sub GetFile() 

Dim fNameAndPath As Variant 
Dim wb As Workbook, wb2 As Workbook 
Dim Ws    As Worksheet 

fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Select File To Be Opened") 
If fNameAndPath = False Then Exit Sub 
Workbooks.Open Filename:=fNameAndPath 

Application.ScreenUpdating = False 

    Set wb = ActiveWorkbook 
    Set wb2 = Workbooks.Add(fNameAndPath) 

For Each Ws In wb2.Worksheets 
    Ws.Copy After:=wb.Sheets(wb.Sheets(1)) 
Next Ws 

Application.ScreenUpdating = True 

End Sub 

Answer 1

Public Sub this() 
    Dim path As String, fileName As String 
    Dim sheet As Worksheet, thisWB As Workbook, thatWB As Workbook 
    Dim arr() As Variant 
    Dim rowC As Long, colC As Long 
    path = "C:\Users\dcoats\Desktop" & "\" 
    fileName = Dir(path & "*.xl??") 
    Set thisWB = ThisWorkbook 
    Do While Len(fileName) > 0 
     Set thatWB = Workbooks.Open(path & fileName, True, True) 
      For Each sheet In thatWB.Sheets 
       arr = sheet.UsedRange 
       rowC = sheet.UsedRange.Rows.Count 
       colC = sheet.UsedRange.Columns.Count 
       thisWB.Sheets.Add After:=Worksheets(Worksheets.Count) 
       thisWB.ActiveSheet.Range(thisWB.ActiveSheet.Cells(1, 1), thisWB.ActiveSheet.Cells(rowC, colC)).Value2 = arr 
      Next sheet 
     thatWB.Close False 
     fileName = Dir() 
    Loop 
End Sub 

für Sie Dies sollte funktionieren. Vorsichtig, obwohl es alle Dateien in einem Verzeichnis durchläuft (tut mir leid, dass ich es im Grunde genommen aus einer Skriptbibliothek kopiert habe).