AW: Excell-Dateien in eine Datei als Sheet
03.09.2015 03:06:01
fcs
Hallo Hans,
probiere mal die folgenden Versionen.
Eigentlich sollte was passendes dabei sein.
Gru0
Franz
Public Sub zustel()
'Tabellen einzeln kopieren
Dim strDatnam As Variant
Dim wb As Workbook, wbZiel As Workbook
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim Anzahl As Long
Set wbZiel = ActiveWorkbook
strDatnam = Application.GetOpenFilename("Datei (*.xl*),*.xl*", False, _
"Bitte gewünschte Datei(en) markieren ", False, True)
If Not IsArray(strDatnam) Then Exit Sub
Set wbZiel = ActiveWorkbook
Application.ScreenUpdating = False
For i = LBound(strDatnam) To UBound(strDatnam)
Set wb = Workbooks.Open(strDatnam(i), ReadOnly:=True)
For j = 1 To ActiveWorkbook.Worksheets.Count
Set ws = wb.Worksheets(j)
With wbZiel
ws.Copy After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = _
"Table" & Format(i, "0_") & Format(j, "0") 'wb.Name & j
End With
Next
wb.Close savechanges:=False
Next
Application.ScreenUpdating = True
Set ws = Nothing
Set wb = Nothing: Set wbZiel = Nothing
End Sub
Public Sub zustel_02()
'Tabellen jeweils als Gruppe kopieren
Dim strDatnam As Variant
Dim wb As Workbook, wbZiel As Workbook
Dim i As Integer
Dim j As Integer
Dim Anzahl As Long
Set wbZiel = ActiveWorkbook
strDatnam = Application.GetOpenFilename("Datei (*.xl*),*.xl*", False, _
"Bitte gewünschte Datei(en) markieren ", False, True)
If Not IsArray(strDatnam) Then Exit Sub
Set wbZiel = ActiveWorkbook
Application.ScreenUpdating = False
For i = LBound(strDatnam) To UBound(strDatnam)
Set wb = Workbooks.Open(strDatnam(i), ReadOnly:=True)
For j = 1 To ActiveWorkbook.Worksheets.Count
wb.Worksheets(j).Name = "Table" & Format(i, "0_") & Format(j, "0") 'wb.Name & j
Next
With wbZiel
wb.Worksheets.Copy After:=.Sheets(.Sheets.Count)
End With
wb.Close savechanges:=False
Next
Application.ScreenUpdating = True
Set ws = Nothing
Set wb = Nothing: Set wbZiel = Nothing
End Sub
Public Sub zustel_03()
'Tabellenbereiche jeweils in neues Tabellenblatt in Zielmappe kopieren
Dim strDatnam As Variant
Dim wb As Workbook, wbZiel As Workbook
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim Zei As Long, Spa As Long
Dim Anzahl As Long
Set wbZiel = ActiveWorkbook
strDatnam = Application.GetOpenFilename("Datei (*.xl*),*.xl*", False, _
"Bitte gewünschte Datei(en) markieren ", False, True)
If Not IsArray(strDatnam) Then Exit Sub
Set wbZiel = ActiveWorkbook
Application.ScreenUpdating = False
For i = LBound(strDatnam) To UBound(strDatnam)
Set wb = Workbooks.Open(strDatnam(i), ReadOnly:=True)
For j = 1 To ActiveWorkbook.Worksheets.Count
With wbZiel
.Worksheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = _
"Table" & Format(i, "0_") & Format(j, "0") 'wb.Name & j
End With
Set ws = wb.Worksheets(j)
With ws
With .UsedRange
Spa = .Column + .Columns.Count - 1
Zei = .Row + .Rows.Count - 1
End With
.Range(.Cells(1, 1), .Cells(Zei, Spa)).Copy
End With
With wbZiel
With .Sheets(.Sheets.Count)
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
End With
End With
Application.CutCopyMode = False
Next
wb.Close savechanges:=False
Next
Application.ScreenUpdating = True
Set ws = Nothing
Set wb = Nothing: Set wbZiel = Nothing
End Sub