Microsoft Excel

Herbers Excel/VBA-Archiv

Neue Tabellenblätter nach Wert in Zelle anlegen


Betrifft: Neue Tabellenblätter nach Wert in Zelle anlegen von: Lars
Geschrieben am: 09.08.2018 10:09:38

Hallo zusammen,

ich verzweifle so langsam.
Folgendes Problem: Ich habe ein Tabellenblatt mit ca. 200 Zeilen und 50 Spalten. In Spalte K stehen Werte von 1-60 (Werte kommen doppelt vor). Jetzt möchte ich gerne neue Tabellenblätter erzeugen, die nach den Werten in Spalte K benannt werden und dazu noch die entsprechende Zeile übernimmt.
Bei einem doppelten Wert soll nur ein Tabellenblatt erzeugt werden, in diesem dann aber entsprechend alle Zeilen, in dem der Wert aus Spalte K vorkommt, kopiert werden.

Ich hoffe das war einigermaßen verständlich und ihr könnt mir helfen:)

Vielen Dank schon einmal.

  

Betrifft: AW: Neue Tabellenblätter nach Wert in Zelle anleg von: Michael (migre)
Geschrieben am: 09.08.2018 10:44:11

Hallo!

Meine Annahme ist, dass im Quell-Blatt keine Überschriften stehen...

Sub a()
    
    Dim Wb As Workbook: Set Wb = ThisWorkbook
    Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle1")
    Dim a, Dic As Object, i&, j&
    
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    With WsQ
        a = .Range("A1:K" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        For i = LBound(a, 1) To UBound(a, 1)
            If Dic.exists(a(i, 11)) Then
                With Wb.Worksheets(CStr(a(i, 11)))
                    For j = LBound(a, 2) To UBound(a, 2)
                        .Cells(.Rows.Count, j).End(xlUp).Offset(1, 0) = a(i, j)
                    Next j
                End With
            Else:
                Dic.Add a(i, 11), ""
                Wb.Worksheets.Add after:=Wb.Worksheets(Wb.Worksheets.Count)
                With Wb.Worksheets(Wb.Worksheets.Count)
                    .Name = CStr(a(i, 11))
                    For j = LBound(a, 2) To UBound(a, 2)
                        .Cells(1, j) = a(i, j)
                    Next j
                End With
            End If
            j = 0
        Next i
        .Activate
    End With
    Set Wb = Nothing: Set WsQ = Nothing: Erase a: Set Dic = Nothing
End Sub
LG
Michael


  

Betrifft: AW: Neue Tabellenblätter nach Wert in Zelle anleg von: Lars
Geschrieben am: 09.08.2018 11:04:34

Hi Michael,

Überschriften bestehen, allerdings sind die nicht wichtig und können gelöscht werden, da die Daten aus den Ziel-Tabellenblättern automatisiert weiter verarbeitet werden.
Das Makro funktioniert perfekt, vielen Dank für die schnelle Hilfe!

VG
Lars


  

Betrifft: AW: Gerne, Danke für die Rückmeldung, owT von: Michael (migre)
Geschrieben am: 09.08.2018 11:07:33




Beiträge aus dem Excel-Forum zum Thema "Neue Tabellenblätter nach Wert in Zelle anlegen"