Hilfe beim Zusammenführen

Hallo,
ich habe mich vorhin schonmal schlau gelesen, auch selbst ein bisschen was an der Datei aus dem folgenden Beitrag im Archiv (1552046) probiert, aber es haben sich noch 2 Probleme ergeben:
https://www.herber.de/forum/archiv/1552to1556/1552046_Excel_Dateien_zu_einer_zusammenfuehren.html#bottom
Also, ich habe ca. 30 EXCEL Dateien, diese möchte ich gerne alle in eine Arbeitsmappe packen (nicht in ein ArbeitsBLATT).
Das Problem ist nur, dass diese Tabellen jeweils keine Überschrfiten haben, nur einen Dateinamen, den ich gerne als Tabellen (Also Arbeitsblatt namen unten ohne .XLSX Endung) hätte.
Also müsste theoretisch bei dem vorhandene Script noch angepasst werden:
- Nicht alles in eine Tabelle, sondern jeweils ein neues Arbeitsblatt öffnen
- Neues Arbeitsblatt umbenennen wie importierte Datei nur ohne Dateiendung.
Meint ihr es wäre möglich das zu programieren?
Außerdem wäre es Klasse, wenn dann Zeile 1 nach unten rutscht und in Zeile 1 auch nochmal der Dateiname aus der Liste der Arbeitsblätter stehen würde.
Lasset die Lösungen beginnen :-)
Schöne Grüße
Patrick Knoke
PS: Wenn gewünscht kann ich auch nochmal 2 Testdateien hochladen, damit ihr mal seht wie die EXCEL Dateien aufgebaut sind.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WbQ As Workbook, WsZ As Worksheet, WsQ As Worksheet Dim Pfad$, Datei$, n$ 'Pfad zu den Quell-Dateien auswählen Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Verzeichnis wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Vorgang abgebrochen", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) & "\" End If End With 'Alle .xls*-Dateien am o.a. Pfad durchgehen 'Das jeweils erste Tabellenblatt wird in ein jeweils 'neues Tabellenblatt in diese Mappe eingelesen Datei = Dir(Pfad & "*.xls*", vbDirectory) Do Until Datei = vbNullString Set WbQ = Workbooks.Open(Pfad & Datei) Set WsQ = WbQ.Worksheets(1) Set WsZ = WbZ.Worksheets.Add(Type:=xlWorksheet) WsQ.UsedRange.Copy WsZ.Cells(2, 1) n = Mid(Datei, 1, InStr(1, Datei, ".") - 1) WsZ.Cells(1, 1) = n: WsZ.Name = n WbQ.Close False Set WbQ = Nothing: Set WsQ = Nothing: Set WsZ = Nothing Loop Set WbZ = Nothing End Sub

Sub a() Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WbQ As Workbook, WsZ As Worksheet, WsQ As Worksheet Dim Pfad$, Datei$, n$ 'Pfad zu den Quell-Dateien auswählen Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Verzeichnis wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Vorgang abgebrochen", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) & "\" End If End With 'Alle .xls*-Dateien am o.a. Pfad durchgehen 'Das jeweils erste Tabellenblatt wird in ein jeweils 'neues Tabellenblatt in diese Mappe eingelesen Datei = Dir(Pfad & "*.xls*", vbDirectory) Do Until Datei = vbNullString Set WbQ = Workbooks.Open(Pfad & Datei) Set WsQ = WbQ.Worksheets(1) Set WsZ = WbZ.Worksheets.Add(Type:=xlWorksheet) WsQ.UsedRange.Copy WsZ.Cells(2, 1) n = Mid(Datei, 1, InStr(1, Datei, ".") - 1) WsZ.Cells(1, 1) = n: WsZ.Name = n WbQ.Close False Datei = Dir Set WbQ = Nothing: Set WsQ = Nothing: Set WsZ = Nothing Loop Set WbZ = Nothing End Sub

Hallo!
Salamitaktik haben wir besonders gern im Forum ;-).
So:

Sub a()
Dim WbZ As Workbook, WbQ As Workbook
Dim WsZ As Worksheet, WsQ As Worksheet, Ws As Worksheet
Dim Pfad$, Datei$, n$, aL As Object, i&
'Pfad zu den Quell-Dateien auswählen
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show  -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1) & "\"
End If
End With
'Neue Arbeitsmappe anlegen (ungespeichert!)
Set WbZ = Workbooks.Add(template:=xlWBATWorksheet)
'Alle .xls*-Dateien am o.a. Pfad durchgehen
'Das jeweils erste Tabellenblatt wird in ein jeweils
'neues Tabellenblatt in die neue Mappe eingelesen
Datei = Dir(Pfad & "*.xls*", vbDirectory)
Do Until Datei = vbNullString
Set WbQ = Workbooks.Open(Pfad & Datei)
Set WsQ = WbQ.Worksheets(1)
Set WsZ = WbZ.Worksheets.Add(Type:=xlWorksheet)
WsQ.UsedRange.Copy WsZ.Cells(2, 1)
n = Mid(Datei, 1, InStr(1, Datei, ".") - 1)
WsZ.Cells(1, 1) = n: WsZ.Name = n
WbQ.Close False
Datei = Dir
Set WbQ = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Loop
'Blätter der neuen Arbeitsmappe alphabetisch sortieren
Set aL = CreateObject("New:{6896B49D-7AFB-34DC-934E-5ADD38EEEE39}")
For Each Ws In WbZ.Worksheets
aL.Add Ws.Name
Next Ws
aL.Sort
For i = 0 To aL.Count - 1
Set Ws = WbZ.Worksheets(aL.Item(i))
Ws.Move after:=WbZ.Worksheets(i + 1)
Next i
Application.DisplayAlerts = False
WbZ.Worksheets(WbZ.Worksheets.Count).Delete
Application.DisplayAlerts = True
Set WbZ = Nothing: Set Ws = Nothing: Set aL = Nothing
End Sub

Siehe auch Kommentare im Code.
LG
Michael

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread