AW: Worksheets aus Workbook übertragen
29.04.2021 17:18:24
Yal
Hallo Dome,
hmm... hätte ich mir denken sollen: die Funktion "Copy" erwartet einen Worksheet-Name oder einen Array of Worksheet-Namen, nicht eine Ausflistung. Das kann man aus dem Code, den der Recorder ausspuckt, herausnehmen. Insbesondere die Unterscheid zwischen einen Worksheet und mehrere Worksheet übertragen.
Dann muss man jede Worksheet aus dem Worksheets in einen Array packen:
Sub Worksheets_uebertragen()
Dim twb As Workbook 'ThisWorkbook
Dim qwb As Workbook 'Quell-Workbook
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Bitte Report auswählen"
.InitialFileName = "C:\Users\Hallo:)\Downloads"
.Filters.Add "Arbeitsmappen", "*.xls*", 1
If .Show = -1 Then strdatei = .SelectedItems(1)
End With
If strdatei "" Then
Set twb = ThisWorkbook
Set wb = Workbooks.Open(strdatei)
wb.Worksheets(SheetsInArray(wb)).Copy after:=twb.Worksheets(twb.Worksheets.Count)
wb.Close SaveChange:=False
End If
End Sub
Private Function SheetsInArray(wb As Workbook)
Dim A(), i
ReDim A(1 To wb.Worksheets.Count)
For i = 1 To wb.Worksheets.Count
A(i) = wb.Worksheets(i).Name
Next
SheetsInArray = A
End Function
Eine Alternative ohne Array wäre:
Sub Worksheets_uebertragen()
Dim twb As Workbook 'ThisWorkbook
Dim qwb As Workbook 'Quell-Workbook
Dim W
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Bitte Report auswählen"
.InitialFileName = "C:\Users\Hallo:)\Downloads"
.Filters.Add "Arbeitsmappen", "*.xls*", 1
If .Show = -1 Then strdatei = .SelectedItems(1)
End With
If strdatei "" Then
Set twb = ThisWorkbook
Set wb = Workbooks.Open(strdatei)
Application.ScreenUpdating = False
For Each W In wb.Worksheets
wb.Worksheets(W.Name).Copy after:=twb.Worksheets(twb.Worksheets.Count)
Next
Application.ScreenUpdating = False
wb.Close SaveChange:=False
End If
End Sub
VG
Yal
