Thema: VBA: Wiederholung von Zahlengruppen in Spalte | Herbers Excel-Forum

Hallo,
ich quäle mich hier mit einem Problem herum, bei dem ich wahrscheinlich eine bessere VBA-Ausbildung
brauchen würde, um es selber lösen zu können. Ich glaube, die Lösung hängt irgendwie mit einem
Array zusammen:
Ich habe eine Spalte mit Zahlen zwischen 0 und 100 und es kommt immer wieder vor, daß mehrere Zahlen hintereinander in genau der Reihenfolge früher (weiter oben schon mal vorkamen). Ich möchte wissen, wann sich eine Gruppe wiederholt hat und in welcher Zeile das war. Hier ein Beispiel
53
30
29
51
25
27
58
86
25
16
66!
53!
89!
43!
37!
21!
44
5
9
16
9
53
41
80
33
80
91
10
27
76
66!
53!
89!
43!
37!
21! Gruppe von 6 Zahlen hat sich wiederholt. War schon in Zeile 12 bis 17 da.
8
6
98
100
65
18
21
Kann mir da bitte jemand helfen?
Die Datei:
https://www.herber.de/bbs/user/66246.xls
Danke,
Born

Hallo,
ab welcher Anzahl? Also wie groß soll eine "Gruppe" mindestens sein? 2, 3, 4 ..... Zahlen?
Gruß
Nepumuk

Hallo Nepumuk,
gute Frage! Am besten wäre, ich könnte das für jede Anzahl aufrufen. Aber eine Gruppenlänge ab 4 aufeinander folgende Zahlen wäre sehr, sehr nützlich.
Born

Hallo,
kannst du mir sagen, wozu das ganze eigentlich gut sein soll? Woher kommen die Zahlen und was machst du mit der Information dass sich eine Gruppe wiederholt? Ich will da nämlich keine Zeit in irgendwelchen Unsinn investieren, denn so einfach ist die Sache nicht. Das Programm muss ja nicht nur nach Wiederholungen suchen, sondern sich auch merken, wo es schon welche gefunden hat. Wenn sich z.B. eine Fünfergruppe wiederholt, dann wiederholen sich natürlich auch die Zahlen 1-4 und 2-5 beim suchen nach Vierergruppen.
Gruß
Nepumuk

Hallo,
kannst ja mal testen ob es so funktioniert.

Sub test()
Dim ArBereich(), ArString(), ArAusgabe()
Dim AnzahlLaenge&, LCount&, A&, AA&
Dim CountTreffer&, temCounter&

On Error Resume Next
AnzahlLaenge = InputBox("Geben Sie die Suchlänge ein", , 6)
If AnzahlLaenge = 0 Then Exit Sub
On Error GoTo 0

ArBereich = Range("A2", Cells(Rows.Count, 1).End(xlUp))

Redim ArAusgabe(1 To Ubound(ArBereich), 1 To 2)

Redim Preserve ArString(Ubound(ArBereich))

For LCount = Lbound(ArBereich) To Ubound(ArBereich)
    For AA = 0 To AnzahlLaenge - 1
     If LCount + AA > Ubound(ArBereich) Then Exit For
     ArString(A) = ArString(A) & ArBereich(LCount + AA, 1)
    Next AA
    A = A + 1
Next LCount

Redim Preserve ArString(A - 1)

For A = Lbound(ArString) To Ubound(ArString)
 For AA = Lbound(ArString) To Ubound(ArString)
   If A <> AA Then
        If ArString(A) = ArString(AA) Then CountTreffer = CountTreffer + 1
        If CountTreffer > temCounter Then
         ArAusgabe((AA + 1), 1) = AnzahlLaenge
         ArAusgabe((AA + 1), 2) = (A + 2)
         temCounter = CountTreffer
        End If
   End If
 Next AA
Next A

Range("B2").Resize(Ubound(ArAusgabe), 2) = ArAusgabe

End Sub

Gruß Tino

Hallo,
hat noch nicht richtig funktioniert, weil z. Bsp. aus 21 & 8 das gleiche wurde wie aus 2 & 18,
daher musste ich den String anders zusammenbauen.

Sub test()
Dim ArBereich(), ArString(), ArAusgabe()
Dim AnzahlLaenge&, LCount&, A&, AA&
Dim CountTreffer&, temCounter&

On Error Resume Next
AnzahlLaenge = InputBox("Geben Sie die Suchlänge ein", , 6)
If AnzahlLaenge = 0 Then Exit Sub
On Error GoTo 0

ArBereich = Range("A2", Cells(Rows.Count, 1).End(xlUp))

Redim ArAusgabe(1 To Ubound(ArBereich), 1 To 2)

Redim Preserve ArString(Ubound(ArBereich))

For LCount = Lbound(ArBereich) To Ubound(ArBereich)
    For AA = 0 To AnzahlLaenge - 1
     If LCount + AA > Ubound(ArBereich) Then Exit For
     ArString(A) = ArString(A) & ";" & ArBereich(LCount + AA, 1)
    Next AA
    A = A + 1
Next LCount

Redim Preserve ArString(A - 1)

For A = Lbound(ArString) To Ubound(ArString)
 For AA = Lbound(ArString) To Ubound(ArString)
   If A <> AA Then
        If ArString(A) = ArString(AA) Then CountTreffer = CountTreffer + 1
        If CountTreffer > temCounter Then
         ArAusgabe((AA + 1), 1) = AnzahlLaenge
         ArAusgabe((AA + 1), 2) = ArAusgabe((AA + 1), 2) & ";" & (A + 2)
         If Left$(ArAusgabe((AA + 1), 2), 1) = ";" Then _
         ArAusgabe((AA + 1), 2) = Right$(ArAusgabe((AA + 1), 2), Len(ArAusgabe((AA + 1), 2)) - 1)
         temCounter = CountTreffer
        End If
   End If
 Next AA
Next A

Range("B2").Resize(Ubound(ArAusgabe), 2) = ArAusgabe

End Sub

Gruß Tino

Hallo Tino,
vielen Dank. Das ist (fast) genau das, was ich gesucht habe. Ich habe es noch
an ein paar Stellen angepaßt und so läuft es. Im wesentlichen habe ich einiges
über Schleifen in Arrays lernen müssen.
Vielen Dank,
Born

Hallo,
wenn Du mir oder uns den angepassten Code zeigen würdest
damit andere die diesen Beitrag lesen auch etwas davon haben.
Gruß Tino

Hallo Born,
mir ist jetzt nur die VBA-Lösung mit roher Gewalt eingefallen, die sich in geschachtelten Schleifen an das Ergebnis heranarbeitet. Da braucht es ggf. schon ein wenig Rechenzeit, wenn die Liste lang ist und die Spanne zwischen Min und Max-Wert der Gruppengöße groß. Bei Größe 4 bis 7 geht es noch recht flott.
Gruß
Franz

Sub GruppenSuchen()
Dim Zeile As Long, Zeilen As Long, StartZeile As Long, Spalte As Long, Ergebnis As Long
Dim LetzterTreffer As Long
Dim rngGrp As Range, GrpLaenge As Long, ZeileGrp As Long, ZeileVergleich As Long
Dim wks As Worksheet, bolIdentisch As Boolean, MinGrpLaenge As Long, MaxGrpLaenge As Long
Set wks = ActiveSheet
With wks
StartZeile = 3 'Zeile mit 1. Wert der Verglichen werden soll
Spalte = 1 'Spalte mit den zu vergleichenden Werten
Ergebnis = 2 'Spalte für Ergebnisausgabe der Gruppenlänge, Spalte daneben wird _
für vorherige Trefferzeile benutzt
'Anzahl Zeilen mit Daten in Spalte
Zeilen = .Cells(.Rows.Count, 1).End(xlUp).Row - StartZeile + 1
MinGrpLaenge = 4 'kleinste Gruppenlänge, die noch verglichen werden soll
MaxGrpLaenge = 7 'größte _
Gruppenlänge, die noch verglichen werden soll
'Altergebnisse löschen
.Range(.Cells(StartZeile, Ergebnis), .Cells(StartZeile + Zeilen - 1, _
Ergebnis + 1)).ClearContents
'Gruppenlänge in 1er-Schritten von maximale auf minimale Gruppenlänge reduzieren
For GrpLaenge = MaxGrpLaenge To MinGrpLaenge Step -1
'Gruppen der Länge in 1er-Schritten durch den Zellenblock verschieben und mit den _
restlichen Zeilen vergleichen
For Zeile = StartZeile To StartZeile + Zeilen - GrpLaenge
Set rngGrp = .Range(.Cells(Zeile, Spalte), _
.Cells(Zeile, Spalte).Offset(GrpLaenge - 1, 0))
LetzterTreffer = Zeile
If Zeile + 2 * GrpLaenge > StartZeile + Zeilen - 1 Then Exit For
'Blöcke bis zur letzten Zeile mit dem Gruppenblock vergleichen
For ZeileGrp = Zeile + GrpLaenge To StartZeile + Zeilen - GrpLaenge
bolIdentisch = True
'Prüfen, ob Zeile schon einem längeren Block als Treffer zugeordnet ist
If IsEmpty(.Cells(ZeileGrp, Ergebnis)) _
Or .Cells(ZeileGrp, Ergebnis) = GrpLaenge Then
'Zeilenweiser Vergleich der Blöcke
For ZeileVergleich = 1 To GrpLaenge
'Wertevergleich und Prüfung, ob Zeile schon Treffer eines längeren Block
If rngGrp.Cells(ZeileVergleich, 1) <> .Cells(ZeileGrp + ZeileVergleich - 1, _
Spalte) _
Or Not (IsEmpty(.Cells(ZeileGrp + ZeileVergleich - 1, Ergebnis)) _
Or .Cells(ZeileGrp, Ergebnis) = GrpLaenge) Then
bolIdentisch = False
Exit For
End If
Next ZeileVergleich
If bolIdentisch = True Then
'Blocklänge in Ergebnisspalte eintragen
.Range(.Cells(ZeileGrp, Ergebnis), _
.Cells(ZeileGrp, Ergebnis).Offset(GrpLaenge - 1, 0)).Value _
= GrpLaenge
'vorherige Trefferzeile eintragen
.Cells(ZeileGrp, Ergebnis + 1).Offset(GrpLaenge - 1, 0) = LetzterTreffer
'vorherigen Trefferwert neu setzen
LetzterTreffer = ZeileGrp
'Zeilenzähler der Schleife anpassen
ZeileGrp = ZeileGrp + GrpLaenge - 1
End If
End If
Next ZeileGrp
Next Zeile
Next GrpLaenge
End With
End Sub