Namen Trennen in neue Blätter

[AKGUSTI]

Hallo Günter, Hallo Martin,
bin erst heute zum austesten gekommen.
ich finde eure beide Lösungen gut, vielen Dank an euch beide erstmals. Aber ich entscheide mich für die Makrolösung.
Nun habe ich eine zusätzliche bitte.

In den Spalten O-P sind leere Zellen die mit Zeit ( 00:00 ) gefüllt werden müssen, geht das auch mit der Makro in einem Schwung, trennen und füllen ?

Vielen Dank im Voraus.

PS Makros sind komplettes Neuland für mich. Bin gerade in Übung, deswegen wären nachvollziehbare Lösungsvorschläge toll! 

Lieben Gruß
Paolo

[snb]

Du sollte erstmals rows(1) löschen.

Und dann reicht:

Code:

Sub M_snb()
'   Sheet1.Rows(1).Delete
   Sheet1.Columns(3).AdvancedFilter 2, , Sheet1.Cells(1, 100), True
   sn = Sheet1.Cells(1, 100).CurrentRegion
   Sheet1.Cells(1, 100).CurrentRegion.Offset(1).ClearContents

   For j = 2 To UBound(sn)
      Sheets.Add(, Sheets(Sheets.Count)).Name = "P_" & sn(j, 1)
      Sheet1.Cells(2, 100) = sn(j, 1)
      Sheet1.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet1.Cells(1, 100).CurrentRegion, Sheets("P_" & sn(j, 1)).Cells(1)
   Next
End Sub

[AlterDresdner]

Hallo Paolo,
ich habe ein paar Kommentare zum besseren Verständnis reingeschrieben und die 0:00-Füllung in O,P hinzugefügt.
Die Formeln werden dabei natürlich überschrieben.
Gruß der Martin

[snb]

@GMG

Ich sehe nur eines Ergebnis, keine Methode. 

[GMG-CC]

Moin,

das Ganze ist mit Power Query / Abrufen und transformieren erstellt worden. Wenn du die Ergebnis-Tabelle klickst und dann im Menü Abfrage Tools/Abfrage das Symbol bearbeiten auswählst, öffnet sich der Query Editor und im rechten Seitenfenster kannst du die einzelnen Schritte nachvollziehen. Den eigentlichen Code siehst du, wenn du dort im Menü Ansicht auf Erweiterter Editor klickst.

Die Logik und die Arbeitsweise des Power Query ist nicht in 1. Linie auf Coding sondern eher auf drag 'n' drop und Co. ausgelegt. Prinzipiell ist das Ergebnis sehr stark an SQL angelehnt wie du gewiss im erweiterten Editor gesehen hast.

[snb]

Statt etwas zu 'drag and drop'-en möchte ich die schon eingebaute Möglichkeiten Excels benützen: Advancedfilter, Querytables, Listobjects oder ADODB-abfrage.

Code:

Sub M_snb_Advancedfilter()
   With Sheet1.Cells(1, 100)
        Sheet1.Columns(3).AdvancedFilter 2, , .Offset, -1
        sn = .CurrentRegion.Value
        .CurrentRegion.ClearContents
   End With
   
   For j = 2 To UBound(sn)
      Sheets.Add(, Sheets(Sheets.Count)).Name = "P_" & sn(j, 1)
      Sheet1.Cells(2, 100) = sn(j, 1)
      Sheet1.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet1.Cells(1, 100).CurrentRegion, Sheets("P_" & sn(j, 1)).Cells(1)
   Next
End Sub

Code:

Sub M_snb_Querytable()
   With Sheet1.Cells(1, 100)
        Sheet1.Columns(3).AdvancedFilter 2, , .Offset, -1
        sn = .CurrentRegion.Value
        .CurrentRegion.ClearContents
   End With
   
   For j = 2 To UBound(sn)
        With Sheets.Add(, Sheets(Sheets.Count))
             With .QueryTables.Add("ODBC;DSN=Excel files;DBQ=" & ThisWorkbook.FullName, .Cells(1))
               .CommandText = "SELECT * FROM [Tabelle1$] WHERE [name]='" & sn(j, 1) & "'"
               .Refresh False
             End With
             .Name = "P_" & sn(j, 1)
        End With
   Next
End Sub

Code:

Sub M_snb_Listobject()
   With Sheet1.Cells(1, 100)
        Sheet1.Columns(3).AdvancedFilter 2, , .Offset, -1
        sn = .CurrentRegion.Value
        .CurrentRegion.ClearContents
   End With
   
   For j = 2 To UBound(sn)
      With Sheets.Add(, Sheets(Sheets.Count))
         With .ListObjects.Add(0, "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Jet OLEDB:Engine Type=35", , , .Cells(1)).QueryTable
            .CommandText = "SELECT * FROM [Tabelle1$] WHERE [name]='" & sn(j, 1) & "'"
            .Refresh False
        End With
        .Name = "P_" & sn(j, 1)
    End With
  Next
End Sub

Code:

Sub M_snb_parsing_ADODB()
   With Sheet1.Cells(1, 100)
        Sheet1.Columns(3).AdvancedFilter 2, , .Offset, -1
        sn = .CurrentRegion.Value
        .CurrentRegion.ClearContents
   End With
   
   For j = 2 To UBound(sn)
        Sheets.Add(, Sheets(Sheets.Count)).Name = "P_" & sn(j, 1)
   
        With CreateObject("ADODB.Recordset")
            .Open "SELECT * FROM [Tabelle1$] WHERE [name]='" & sn(j, 1) & "'", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""
            Sheets("P_" & sn(j, 1)).Cells(1).CopyFromRecordset .DataSource
        End With
    Next
End Sub

[GMG-CC]

Es ist dir ja unbenommen, einen eher akademischen Weg zu gehen.
Ich habe rein gar nichts gegen die Möglichkeiten, die Excel per se bietet. 
Aber beginnend mit 2016 ist Power Query auch Teil des nativen Excel, insofern ist dein Argument bei aktuellen Excel-Versionen nicht mehr nachvollziehbar (so weit ich es richtig verstanden habe).
Und ich sehe mich eher auf der Seite eines "typischen" Anwenders, der/die nun einmal mit drag 'n' drop meistens besser zurecht kommt und nicht bei jeder kleinen Änderung auf das Forum (oder den bezahlten Dienstleister) angewiesen ist (auch wenn ich zu der letztgenannten Gruppe gehöre).

Ansonsten: Es ist gut, dass verschiedene Wege zum Ziel führen und jeder Leser/Nutzer aus den angebotenen -teils sehr unterschiedlichen- Möglichkeiten wählen kann.

[AKGUSTI]

Hallo Martin,

das ist super , aber ich habe mich verschrieben, es sind die Spalten O - R die gefüllt werden sollen.

Es wäre gut wenn du mir die Zeile Schreibst die geändert werden muss , oder wie der Code satz lautet.

Gruß
Paolo

[AlterDresdner]

Hallo Paolo,
Du musst nur die Zeile
            With AB.ActiveSheet 'leere Zellen in Spalte O,R = Spalte 15..18 mit 0 füllen
              For Each zelle In .Range(.Cells(2, 15), .Cells(anz + 2, 18))

ändern. Der 2. Parameter von Cells(z,s) ist die Spaltennummer, der 1. die Zeile. Range(z1,z2) beschreibt den zu bearbeitenden Zellbereich.
Ein Blick in die Hilfe (Begriff markieren, F1 drücken) hilft weiter.
Gruß der Martin