Office: mehrere Tabellenblätter in einem Tabellenblatt zusammenführen

maggifrosch · 17. November 2009

Hallo zusammen,
ich erhalte nach einer Datenbankabfrage folgende Auswertung (siehe Excel-Datei) mit den Tabellenblättern Beispiel 2, 6, 10 und 15. Wobei die Auswertung eigentlich erst in der Zeile 18 mit den Überschriften beginnt. Und diese sollen in einem Tabellenblatt zusammengeführt werden so wie im Tabellenblatt "Resultat" dargestellt. In Zeile 1 sollen die jeweiligen Überschriften aus den einzelnen Tabellenblätter genommen werden. Doppelte Überschriften überschreiben und neue am Ende hinzufügen. Anschließend folgen die weiteren Zeilen.

Oder gibt es vielleicht eine andere Lösung? Freue mich über jede Hilfe bzw. Idee.

Was ich bis jetzt habe ist folgendes: Wenn alle Tabellenblätter den gleichen Aufbau haben, dann kopiert er mir allen Tabellenblätter schön untereinander.
Erst die Überschrift und dann die Werte.

Schon mal im voraus vielen Dank.

Beste Grüße
maggifrosch
P.S.: ich vergaß zu erwähnen: Es wäre noch schön wenn es die Möglichkeit gäbe

:)

jinx · 24. November 2009

Moin, maggifrosch,

hier wird vorausgesetzt, dass die Tabelle Resultat mit den Überschriften in den ersten 6 Spalten vorliegt:

Code:

Sub Zusammenschreiben()

Dim ws As Worksheet
Dim wsTotal As Worksheet
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim rngTotalFound As Range
Dim lngTotalRow As Long
Dim lngCounter As Long
Dim strSearch As String

On Error GoTo Zusammenschreiben_Error

Application.ScreenUpdating = False
Set wsTotal = Sheets("Resultat")
For Each ws In Worksheets
If ws.Name wsTotal.Name Then
lngTotalRow = wsTotal.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print lngTotalRow
With ws
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A2:F" & lngLastRow).Copy Destination:=wsTotal.Range("A" & lngTotalRow)
If lngLastCol > 6 Then
For lngCounter = 7 To lngLastCol
strSearch = ws.Cells(1, lngCounter)
Set rngTotalFound = wsTotal.Rows("1:1").Find( _
what:=strSearch, LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByRows)
If rngTotalFound Is Nothing Then
Set rngTotalFound = wsTotal.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
rngTotalFound.Value = strSearch
End If
.Range(Cells(2, lngCounter).Address, Cells(lngLastRow, lngCounter).Address).Copy Destination:=wsTotal.Cells(lngTotalRow, rngTotalFound.Column)
Next lngCounter
End If
End With
End If
Next ws

exit_here:
Set rngTotalFound = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub

Zusammenschreiben_Error:

MsgBox "Fehler " & Err.Number & " (" & Err.Description & ") in der Prozedur Zusammenschreiben"
Resume exit_here

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gela-Sys · 12. Mai 2010

Hi,

ich bin neu hier und habe ein sehr ähnliches Problem. Ehrlich gesagt habe ich von VBA wenig Ahnung, bin also ein Greenhorn!
Das Script funktioniert toll, aber wie krieg ich das hin, dass er mir nicht alle Tabellenblätter nimmt, sondern nur 6-17?

1000 Dank!
Gela-Sys

jinx · 12. Mai 2010

Moin, Gela-Sys,

was bedeutet 6 bis 17? Die Position innerhalb der Mappe oder die Angabe am Ende der Tabellen? Hier ein Beispiel für die Position innerhalb der Mappe:

Code:

'...
For Each ws In Worksheets
Select Case ws.Index
Case 6 To 17
lngTotalRow = wsTotal.Cells(Rows.Count, "A").End(xlUp).Row + 1
With ws
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A2:F" & lngLastRow).Copy Destination:=wsTotal.Range("A" & lngTotalRow)
If lngLastCol > 6 Then
For lngCounter = 7 To lngLastCol
strSearch = ws.Cells(1, lngCounter)
Set rngTotalFound = wsTotal.Rows("1:1").Find( _
what:=strSearch, LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByRows)
If rngTotalFound Is Nothing Then
Set rngTotalFound = wsTotal.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
rngTotalFound.Value = strSearch
End If
.Range(Cells(2, lngCounter).Address, Cells(lngLastRow, lngCounter).Address).Copy Destination:=wsTotal.Cells(lngTotalRow, rngTotalFound.Column)
Next lngCounter
End If
End With
Case Else
End Select
Next ws
'...
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: mehrere Tabellenblätter in einem Tabellenblatt zusammenführen

mehrere Tabellenblätter in einem Tabellenblatt zusammenführen

mehrere Tabellenblätter in einem Tabellenblatt zusammenführen

mehrere Tabellenblätter in einem Tabellenblatt zusammenführen

mehrere Tabellenblätter in einem Tabellenblatt zusammenführen - Similar Threads - Tabellenblätter Tabellenblatt zusammenführen

Arbeitszeiten aus mehreren Tabellenblätter

Excel Tabellenblatt als PDF speichern unter Vorgabe Dateinamen aus einer Zelle

Textblock/Zellbereich aus Tabellenblatt in Worddokument übergeben

Ein Tabellenblatt, dass in mehrfach verwendet wird aktuell halten

Mehrere Tabellenblätter zusammenführen

VBA: XLSX-Dateien in verschiedene Tabellenblätter in einer XLXS-Datei zusammenführen

Mehrere Excel Dateien in ein Tabellenblatt zusammenführen