Daten nach Überschrift zusammenfassen

Forumthread: Daten nach Überschrift zusammenfassen

11.12.2020 08:34:32

Klaus

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

AW: mit VBA möglich

11.12.2020 09:13:16

Fennek

Hallo,
mit VBA geht das, ob sich jemand findet dir einen Code zu schreiben, ist eine andere Frage.
mfg

AW: Daten nach Überschrift zusammenfassen

11.12.2020 09:17:16

UweD

Hallo
versuch das hier...
in ein Modul


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

LG UweD

AW: Daten nach Überschrift zusammenfassen

11.12.2020 10:49:14

Klaus

Hallo Uwe,
vielen Dank, das funktioniert wunderbar, genau so habe ich mir das vorgestellt.
Ist es zusätzlich möglich, den Namen vom jeweiligen Tabellenblatt in Spalte A hinzuzufügen? So dass ich sofort eine Verbundung Eintrag in neuer Liste zum Tabellenblatt herstellen kann.
Vielen Dank schonmal für deinen tollen VBA Code der mir das Leben wirklich erleichtert.
Viele Grüße
Klaus

AW: Daten nach Überschrift zusammenfassen

11.12.2020 11:08:43

UweD

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

AW: Daten nach Überschrift zusammenfassen

11.12.2020 12:14:39

Klaus

Hallo Uwe,
vielen herzlichen Dank, Du hast mir sehr geholfen. Das funktioniert genau so wie ich es mir vorgestellt habe. Außerdem läuft das Makro sehr schnell.
Vielen Dank und ein schönes Wochenende
LG
Klaus

Prima. Danke für die Rückmeldung. owT

11.12.2020 12:24:20

UweD

Beliebteste Forumthreads (12 Monate)

Daten nach Überschrift zusammenfassen

Forumthread: Daten nach Überschrift zusammenfassen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Daten nach Überschrift zusammenfassen

Forumthread: Daten nach Überschrift zusammenfassen

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread