Daten nach Überschrift zusammenfassen

Guten Tag zusammen,
mein Problem: ich habe eine Arbeitsmappe mit 40 Tabellenblättern, diese sind nur in den Spalten A-E in den Spaltenüberschriften identisch. Ab Spalte F bis Z kommt je Tabellenblatt eine unterschiedliche Anzahl Spalten. Mal von A - F mal kann es sein das von A - Z befüllt ist. Die Spalten A bis E sind immer mit Werten befüllt alle anderen teilweise nicht vollständig. Mein Plan: Im Blatt Daten werden alle Tabellenblätter zusammengefasst. Hier finden sich alle möglichen Überschriften aus den verschiedenen Blättern. Es wird in allen Blättern nach den Überschriften aus Blatt "Daten" gesucht und alle Werte eingefügt. Also Ende Spalte A (die ja immer befüllt ist und Ende Zeile 1 (Überschriften) suchen, kopieren und Werte einfügen. Leider stehen die Überschriften immer in anderen Spalten -mal steht Test in Spalte A mal steht Test in Spalte G oder sonst wo.
Gibt es dafür eine Lösung?
Vielen Dank für eure Unterstützung
Gruß
Klaus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Zusammenfassen() Dim TB1 As Worksheet, TB As Worksheet Dim LR1 As Long, LRx As Long Dim LC As Integer, LCx As Integer, SP As Integer Set TB1 = Sheets("Daten") For Each TB In ThisWorkbook.Sheets If TB.Name TB1.Name Then LR1 = TB1.Cells(TB1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte LRx = TB.Cells(TB.Rows.Count, 1).End(xlUp).Row 'A-E kopieren TB1.Cells(LR1 + 1, 1).Resize(LRx - 1, 5).Value = _ TB.Cells(2, 1).Resize(LRx - 1, 5).Value 'REst kopieren LCx = TB.Cells(1, TB.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile For SP = 6 To LCx 'Prüfen, ob Überschrift schon da If WorksheetFunction.CountIf(TB1.Rows(1), TB.Cells(1, SP)) = 0 Then 'Neu LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column + 1 TB1.Cells(1, LC).Value = _ TB.Cells(1, SP).Value Else 'schon da LC = WorksheetFunction.Match(TB.Cells(1, SP), TB1.Rows(1), 0) End If 'Werte in entsprechende Spalten kopieren TB1.Cells(LR1 + 1, LC).Resize(LRx - 1, 1).Value = _ TB.Cells(2, SP).Resize(LRx - 1, 1).Value Next End If Next End Sub

Hi
dann muss aber Spalte A-E in Daten.Spalte B-F kopieren und in A der Name


Sub Zusammenfassen()
Dim TB1 As Worksheet, TB As Worksheet
Dim LR1 As Long, LRx As Long
Dim LC As Integer, LCx As Integer, SP As Integer
Set TB1 = Sheets("Daten")
For Each TB In ThisWorkbook.Sheets
If TB.Name  TB1.Name Then
LR1 = TB1.Cells(TB1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
LRx = TB.Cells(TB.Rows.Count, 1).End(xlUp).Row
'A-E kopieren in B-F
TB1.Cells(LR1 + 1, 2).Resize(LRx - 1, 5).Value = _
TB.Cells(2, 1).Resize(LRx - 1, 5).Value
'Blattname einfügen
TB1.Cells(LR1 + 1, 1).Resize(LRx - 1, 1).Value = TB.Name
'Hyper Link einfügen
TB1.Hyperlinks.Add Anchor:=TB1.Cells(LR1 + 1, 1).Resize(LRx - 1, 1), Address:="", _
SubAddress:=TB.Name & "!A1", TextToDisplay:=TB.Name
'REst kopieren
LCx = TB.Cells(1, TB.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
For SP = 6 To LCx
'Prüfen, ob Überschrift schon da
If WorksheetFunction.CountIf(TB1.Rows(1), TB.Cells(1, SP)) = 0 Then
'Neu
LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column + 1
TB1.Cells(1, LC).Value = _
TB.Cells(1, SP).Value
Else
'schon da
LC = WorksheetFunction.Match(TB.Cells(1, SP), TB1.Rows(1), 0)
End If
'Werte in entsprechende Spalten kopieren
TB1.Cells(LR1 + 1, LC).Resize(LRx - 1, 1).Value = _
TB.Cells(2, SP).Resize(LRx - 1, 1).Value
Next
End If
Next
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Daten nach Überschrift zusammenfassen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

200 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten nach Überschrift zusammenfassen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

200 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread