VBA: zusammenfassen / zusätzliche Spalte

Hallo zusammen,

ich nutze aktuell dieses Makro um verschiedene Reiter zusammenzufassen. (Ich bin absoluter Laie und habe mir das im Internet herausgesucht).

Nun hätte ich gerne, dass Excel beim Zusammenfassen eine Spalte beifügt, in welcher der Reiter Name steht. Ist so etwas möglich? Ich meine das schon mal gesehen zu haben. ;)

VG
Jörg

Sub zusammenfassen()

Dim WkSh_Q As Worksheet ' die Quell-Tabellenblätter - die Herkunftblätter
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim lZeile_Q As Long ' der For/Next Schleifen-Index im Quell-Tabellenblatt
Dim lZeile_Z As Long ' die Ausgabezeile im Ziel-Tabellenblatt

Application.ScreenUpdating = False ' kein Bildschirm-Update - kein Flackern

Set WkSh_Z = ThisWorkbook.Worksheets("Zusammenfassung") ' das Ausgabeblatt

For Each WkSh_Q In ThisWorkbook.Worksheets ' über alle Blätter der Mappe laufen
If WkSh_Q.Name > "Gesamt" And _
WkSh_Q.Name > "Zusammenfassung" And _
WkSh_Q.Name > "Quartal" Then ' hier können Blätter ausgeschlossen werden
' ab Zeile 17 bis zur letzten belegten Zelle in Spalte 1 = A
For lZeile_Q = 20 To WkSh_Q.Cells(Rows.Count, 2).End(xlUp).Row
' ist die Zeile die kopiert werden soll NICHT leer?
If WorksheetFunction.CountA(WkSh_Q.Rows(lZeile_Q)) > 0 Then
' im Ziel-Tabellenblatt die nächste freie Zeile in Spalte 1 = A suchen
lZeile_Z = WkSh_Z.Cells(Rows.Count, 25).End(xlUp).Row + 1
' ist die erste freie Zeile im Ziel-Tabellenblatt 1, dann nimm 1
' hier kann natürlich eine andere Start-Zeile gewählt werden, 20 gewählt, weil dort die Daten starten
If lZeile_Z 1 Then lZeile_Z = 1
' die Zeile aus dem Quell-Tabellenblatt ==> ZielTabellenblatt kopieren
WkSh_Q.Rows(lZeile_Q).Copy
WkSh_Z.Rows(lZeile_Z).PasteSpecial Paste:=xlValues
End If
Next lZeile_Q
End If
Next WkSh_Q

Application.ScreenUpdating = True

End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub zusammenfassen() Dim WkSh_Q As Worksheet ' die Quell-Tabellenblätter - die Herkunftblätter Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe Dim lZeile_Q As Long ' der For/Next Schleifen-Index im Quell-Tabellenblatt Dim lZeile_Z As Long ' die Ausgabezeile im Ziel-Tabellenblatt Application.ScreenUpdating = False ' kein Bildschirm-Update - kein Flackern Set WkSh_Z = ThisWorkbook.Worksheets("Zusammenfassung") ' das Ausgabeblatt For Each WkSh_Q In ThisWorkbook.Worksheets ' über alle Blätter der Mappe laufen If WkSh_Q.Name > "Gesamt" And _ WkSh_Q.Name > "Zusammenfassung" And _ WkSh_Q.Name > "Quartal" Then ' hier können Blätter ausgeschlossen werden ' ab Zeile 17 bis zur letzten belegten Zelle in Spalte 1 = A For lZeile_Q = 20 To WkSh_Q.Cells(Rows.Count, 2).End(xlUp).Row ' ist die Zeile die kopiert werden soll NICHT leer? If WorksheetFunction.CountA(WkSh_Q.Rows(lZeile_Q)) > 0 Then ' im Ziel-Tabellenblatt die nächste freie Zeile in Spalte 1 = A suchen lZeile_Z = WkSh_Z.Cells(Rows.Count, 25).End(xlUp).Row + 1 ' ist die erste freie Zeile im Ziel-Tabellenblatt 1, dann nimm 1 ' hier kann natürlich eine andere Start-Zeile gewählt werden, 20 gewählt, weil dort die Daten starten If lZeile_Z 1 Then lZeile_Z = 1 ' die Zeile aus dem Quell-Tabellenblatt ==> ZielTabellenblatt kopieren WkSh_Q.Rows(lZeile_Q).Copy WkSh_Z.Rows(lZeile_Z).PasteSpecial Paste:=xlValues WkSh_Z.Cells(lZeile_Z, Columns.Count).End(xlToLeft).Offset(0, 1) = WkSh_Q.Name End If Next lZeile_Q End If Next WkSh_Q Application.ScreenUpdating = True End Sub

Hallo Jörg,

benutze bitte das nächstemal den Code-Button. Die End(xlUp)-Funktion liefert mindenstens 1.
Ich habe dir nur beispielhaft die Codezeile für den Blattnamen eingefügt.

Sub Zus2()

Dim WkSh_Q As Worksheet ' die Quell-Tabellenblätter - die Herkunftblätter
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim lZeile_Q As Long ' der For/Next Schleifen-Index im Quell-Tabellenblatt
Dim lZeile_Z As Long ' die Ausgabezeile im Ziel-Tabellenblatt

Application.ScreenUpdating = False ' kein Bildschirm-Update - kein Flackern

Set WkSh_Z = ThisWorkbook.Worksheets("Zusammenfassung") ' das Ausgabeblatt

For Each WkSh_Q In ThisWorkbook.Worksheets ' über alle Blätter der Mappe laufen
    
    If WkSh_Q.Name > "Gesamt" And _
       WkSh_Q.Name > "Zusammenfassung" And _
       WkSh_Q.Name > "Quartal" Then ' hier können Blätter ausgeschlossen werden
            
            ' ab Zeile 17 bis zur letzten belegten Zelle in Spalte 1 = A
            For lZeile_Q = 20 To WkSh_Q.Cells(Rows.Count, 2).End(xlUp).Row
                
                ' ist die Zeile die kopiert werden soll NICHT leer?
                If WorksheetFunction.CountA(WkSh_Q.Rows(lZeile_Q)) > 0 Then
                    ' im Ziel-Tabellenblatt die nächste freie Zeile in Spalte 1 = A suchen
                    lZeile_Z = WkSh_Z.Cells(Rows.Count, 25).End(xlUp).Row + 1
                    ' ist die erste freie Zeile im Ziel-Tabellenblatt  1, dann nimm 1
                    ' hier kann natürlich eine andere Start-Zeile gewählt werden, 20 gewählt, weil dort die Daten starten
                    If lZeile_Z  1 Then lZeile_Z = 1
                    ' die Zeile aus dem Quell-Tabellenblatt ==> ZielTabellenblatt kopieren
                    WkSh_Q.Rows(lZeile_Q).Copy
                    WkSh_Z.Rows(lZeile_Z).PasteSpecial Paste:=xlValues
                            WkSh_Z.Cells(lZeile_Z, "AA") = WkshQ.Name '-- Oder eine andere Spalte nehmen! XXXXXX
                End If
            
            Next lZeile_Q
    
    End If

Next WkSh_Q

Gruß Gerd

Beliebteste Forumthreads (12 Monate)

VBA: zusammenfassen / zusätzliche Spalte

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread