Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1616to1620
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabelle separieren

Tabelle separieren
04.04.2018 13:17:44
Pat
Hallo liebes Forum,
wollte mir ein kleines Makro bauen und bekomme es nicht hin.
Habe eine Tabelle in der in Spalte A verschiedene Namen aufgelistet, die letzte Zeile des jeweiligen Namen ist eine Ergebniszeile (Name in Zeile vorhanden).
Per Makro möchte ich jetzt, dass er separate Excel-Dateien (oder Arbeitsblätter) für die jeweiligen Namen erstellt mit Ergebniszeile und beiden Überschriftzeilen oben. Hier eine Beispieltabelle:
https://www.herber.de/bbs/user/120848.xlsx
Habe es bisher nur mit vorher definiertem Suchwort geschafft die Tabelle zu filtern. Aber da sich die Namen häufig ändern macht es keinen Sinn.
Vielen Dank im Voraus für Tipps!
Grüße Pat

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabelle separieren
04.04.2018 15:45:55
UweD
Hallo
so?
Sub Gruppe_neues_Blatt()
    On Error GoTo Fehler
    Dim EZ As Integer, SP As Integer, LR As Double, i As Double
    Dim Such As String, Last As Double, TB1, TB2
    
    Set TB1 = ActiveSheet
    EZ = 2 ' Überschrift 
    SP = 1 'Spalte A 
    Such = "Ergebnis"
    
    LR = TB1.Cells(TB1.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
    Last = LR
    
    For i = LR - 1 To EZ + 1 Step -1
        If InStr(TB1.Cells(i, SP), Such) > 0 Or i = EZ + 1 Then
            
            Sheets.Add After:=Sheets(Sheets.Count)
            Set TB2 = ActiveSheet
            
            'Überschrift 
            TB1.Rows("1:" & EZ).Copy TB2.Rows(1)
            
            TB1.Range(TB1.Rows(i + 1), TB1.Rows(Last)).Copy TB2.Rows(EZ + 1)
            TB2.Name = TB2.Cells(EZ + 1, SP).Text
            
            Last = i
                
        End If
    Next
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
update
04.04.2018 15:57:40
UweD
Die erste Zeile wurde vergessen.
Sub Gruppe_neues_Blatt()
    On Error GoTo Fehler
    Dim EZ As Integer, SP As Integer, LR As Double, i As Double
    Dim Such As String, Last As Double, TB1, TB2
    
    Set TB1 = ActiveSheet
    EZ = 2 ' Überschrift 
    SP = 1 'Spalte A 
    Such = "Ergebnis"
    
    LR = TB1.Cells(TB1.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
    Last = LR
    
    For i = LR - 1 To EZ Step -1
        If InStr(TB1.Cells(i, SP), Such) > 0 Or i = EZ Then
            
            Sheets.Add After:=Sheets(Sheets.Count)
            Set TB2 = ActiveSheet
            
            'Überschrift 
            TB1.Rows("1:" & EZ).Copy TB2.Rows(1)
            
            TB1.Range(TB1.Rows(i + 1), TB1.Rows(Last)).Copy TB2.Rows(EZ + 1)
            TB2.Name = TB2.Cells(EZ + 1, SP).Text
            
            Last = i
                
        End If
    Next
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
AW: update
05.04.2018 08:33:08
Pat
oh, vergessen mich zu bedanken!
Freue mich sehr, Dankeschön!
Gern geschehen owT
05.04.2018 09:05:47
UweD

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige