Mehrere Excel Tabellen zusammenfügen

[ExcelMakroHilfe]

Hallo!

Ich hoffe Ihr könnt mir weiterhelfen. Ich stehe vor einem kleinen großen Problem.

Ich habe eine "Masterdatei", in der eine Tabelle ist. Von B1-B9 bis X1-X9 eine Statistik, von B10-12 die Überschrift ist und ab B12 die Spaltenbezeichnung für die Tabelle anfängt. Diese Spaltenbezeichnungen der Tabellen geht bis W12.

Also würde es ungefähr so aussehen: (kleineres Format)

Mitarbeiter
Vorname Nachname Alter Anrede

Und da drunter würden dann die Daten stehen.


Nun werde ich diese Masterdatei wegschicken und ausgefüllt zurückbekommen. Ungefähr 50 einzelne Dateien.
Nun wollte ich dies automatisieren, damit die einzelnen Dateien, in der Masterdatei zusammenkommen und die Tabelle erweitern.

Nun habe ich zwei Anläufe mit Makros gestartet.
1.

Code:

Sub TabellenKopieren()
Dim i As Integer
With ActiveWorkbook
'neue Tabelle an die erste Position einfügen
.Worksheets.Add Before:=.Worksheets(1)
For i = 2 To .Worksheets.Count
'Ermitteln den benutzen Bereich der einzelnen Tabellenblätter
Set Rng = .Worksheets(i).UsedRange
'letzte Zeile ermitteln des ersten Blattes
Set rng1 = Worksheets(1).Cells(Rows.Count, "A").End(xlUp)(2)
'Bereich kopieren
Rng.Copy Destination:=rng1
Next
End With
End Sub

-> Hier liegt das Problem, dass ich die einzelnen Dateien, in der Masterdatei als Tabelle hinzufügen muss. Dazu kopiert er hier auch die Statistiken mit, was ich ja nicht möchte.

2.

Code:

Sub Zusammenführen()
Dim i As Long
Dim sPfad As String
Dim sDatei As String
Dim vFileToOpen As Variant
Dim lngLZ As Long
Dim blnÜberschrift As Boolean
Dim iCalc As Integer


vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If Not IsArray(vFileToOpen) Then Exit Sub


iCalc = Application.Calculation

On Error GoTo ENDE:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


For i = 1 To UBound(vFileToOpen)
sDatei = Dir(vFileToOpen(i))
sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)

With Tabelle1.Range("A1")
.Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$A:$A<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))"
lngLZ = .Value
End With

With Tabelle1
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 15).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 15).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
End If
End With

Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
Next

With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(1).Delete
End With

ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub

Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100)
Dim Mess, Z, Rest
Static oldStatusBar As Integer
Static blnInit As Boolean

If Not blnInit Then
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
End If

Mess = ""
For Z = 1 To ProzentSatz
Mess = Mess & ChrW(Val("&H25A0"))
Next Z
Rest = 100 - ProzentSatz
For Z = 1 To Rest
Mess = Mess & ChrW(Val("&H25A1"))
Next Z
Application.StatusBar = Mess & " " & ProzentSatz & "%"

If Rest <= 0 Then
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
End If
End Sub

-> Bei diesem hier wiederum, kann ich die einzelnen Dateien auswählen. Aber hier kopiert er wieder die Statistiken mit und füllt bei leeren Zeilen eine "0" aus. Wobei er bei den Statistiken die Formatierung auch nicht übernimmt.


Ich hoffe ich konnte mich klar ausdrücken, falls noch Fragen anstehen, stehe ich gerne zur Verfügung.

Vielen Dank für Eure Hilfe!

LG

[GMG-CC]

Moin,
prinzipiell sollte das sehr gut mit Power Query -> http://www.excel-ist-sexy.de/power-query-das-add-in/ machbar sein.
Deinen Code habe ich nicht analysiert, weil ich einfach keine Lust habe, einen "Trockenkurs Schwimmen" ohne Daten zu machen ...

[kadrleyn]

Ich habe eine vorlage zu diesem thema.

Excel-Benutzer müssen in der regel mehrere arbeitsblätter zu einem einzigen arbeitsblatt zusammenführen, sodass die daten schnell und einfach analysiert werden können.

https://youtu.be/EO8qq_mMF3Y

Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Grand_Table"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Last = FindLastRow(Sheets(1))
Selection.Copy
With Sheets(1).Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats
 End With
 Next
...
Sheets("Grand_Table").UsedRange.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True
...