Hi Peter,
es ist sehr kontraproduktiv, dass
1. es keine extra Spalte gibt, in welcher der Serienname steht ohne jegliche Zusätze - Excel weiß ja nicht, wo in Spalte A der Name der Serie endet und weitere Zusätze beginnen. Aus diesem Grund kann der Code nur den Inhalt der ersten Zelle einer Serie einschließlich der zusätzlichen Daten ausgeben - das musst du dann von Hand anpassen
2. nur das Ende einer Serie in Spalte M und nicht auch der Anfang gekennzeichnet ist.
Beides erschwert das ganze ungemein.
Aus deiner Mappe geht nicht hervor, in welcher Tabelle das Ergebnis ausgegeben werden soll - ich habe deshalb willkürlich "Tabelle2" im Code festgelegt - musst du anpassen.
Bedingung ist, dass die Daten nach Spalte A sortiert vorliegen.
Sub Zusammenfassen()
Dim lngZeile As Long
Dim intZaehler As Integer
Dim lngAnzahl As Long
Dim strVergleich As String
Dim arrDaten()
Dim lngDaten As Long
For lngZeile = 2 To IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
If Cells(lngZeile, 1) = "" Then Exit For
strVergleich = Mid(Cells(lngZeile, 1), 1, Application.Round(Len(Cells(lngZeile, 1)) / 2, 0))
For intZaehler = 1 To Len(strVergleich)
If Asc(Mid(strVergleich, intZaehler, 1)) > 47 And Asc(Mid(strVergleich, intZaehler, 1)) < 58 Then
strVergleich = Left(Cells(lngZeile, 1), intZaehler - 1)
Exit For
End If
Next intZaehler
lngAnzahl = 1
ReDim Preserve arrDaten(0 To 1, 0 To lngDaten)
arrDaten(0, lngDaten) = Cells(lngZeile, 1)
Do
If Cells(lngZeile + 1, 1) Like strVergleich & "*" Then
lngAnzahl = lngAnzahl + 1
Else
Exit Do
End If
lngZeile = lngZeile + 1
Loop While InStr(Cells(lngZeile, 13), "SEZE") = 0 Or Cells(lngZeile, 1) = ""
If lngAnzahl > 1 Then arrDaten(1, lngDaten) = lngAnzahl
lngDaten = lngDaten + 1
lngAnzahl = 0
Next lngZeile
With Worksheets("Tabelle2")
.Cells.ClearContents
.Range("A1").Resize(lngDaten, 2) = Application.Transpose(arrDaten())
End With
End Sub
Übrigens konnte ich deine Mappe nur im schreibgeschützten Zusand öffnen und musste deshalb die Daten in eine andere Arbeitsmappe kopieren.
Bis später, Karin
