Gleiche 5'er Kombinationen gleich einfärben

... mit einem ähnlichen Anliegen war ich hier bereits vorstellig vor Kurzem,
Liebe Excel-Gemeinde!
... nur komm ich in dieser neuen abgewandelten Problemstellung den entscheidenden Schritt nun nicht weiter. Daher wäre ich sehr froh, wenn sich einer der Sache mit etwas Distanz annimmt. Ich sehe hier vor lauter i's und u's irgendwie nur noch Tiernamen :).
Ausgangspunkt sind 5'er-Blöcke (hier mal in Form von Tiernamen), fortlaufend von links nach rechts in gleichem Spaltenabstand angeordnet, wie in der Datei anbei zu sehen: aber Zeilen sind unterschiedlich lang:
https://www.herber.de/bbs/user/127520.xlsx
Ich bekomme diese jeweils 5 Zellen auch gut ins Array, Zeile für Zeile untereinander. Aber hier dran scheitert's momentan:
Alle 5'er Blöcke desselben Inhalts (d.h. mit der selben Tier-Kombination) sollen mit der selben Farbe gefärbt werden. Wie stell ich das an? Es muss ja das Array mit sich selbst ..., wenn ihr versteht, was ich meine.
Am Ende , wenn alles so klappt wie ich mir das vorstelle, sehe ich also anhand der Farbe schnell auf einen Blick, welche Blöcke gleich sind und welche nicht.
Meint Ihr Ihr könnt mir dabei bitte unter die Arme greifen. Würde mich sehr freuen!
Onurs Code von damals habe ich etwas abgewandelt, aber nun ? :

Option Explicit

Private Sub CommandButton1_Click()
Dim ze(1000) As Integer
Dim sp(1000) As Integer
Dim Arrii(), SammelArr()
Dim i, ii, iii, x, m, n, y
Dim z, s, farbklecks, txtQ
For s = 1 To 30 Step 3
For z = 1 To 19
If Cells(z, s) = "" Then Exit For
i = i + 1
ze(i) = z
sp(i) = s
Next z
Next s
s = Empty
z = Empty
i = Empty
ReDim Arrii(199, 4)
For iii = 1 To 200 Step 5
x = x
For ii = (1 + iii - 1) To (5 + iii - 1)
y = ii - iii
z = ze(ii): s = sp(ii)
If z = 0 Then Exit For
If Cells(z, s) = "" Then Exit For
txtQ = Cells(z, s).Text
txtQ = Replace(txtQ, " ", "")
Arrii(x, ii - iii) = txtQ
Next ii
x = x + 1
Next iii
iii = Empty
ii = Empty
x = Empty
txtQ = Empty
ReDim SammelArr(199)
For m = 0 To 199
For y = 1 To 199 - x
x = x
For n = 0 To 4
If Arrii(m, n) = Arrii(m + y, n) Then
SammelArr(m) = farbklecks + 1
SammelArr(m + y) = farbklecks + 1
Else
SammelArr(m) = "kein" & farbklecks
GoTo Sprung
End If
Next n
x = x + 1
Sprung:
Next y
farbklecks = farbklecks + 1
Next m
m = Empty
n = Empty
x = Empty
y = Empty
End Sub

Danke und beste Grüße
Toni

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Dim ze(1000) As Integer Dim sp(1000) As Integer Dim Arrii(), SammelArr(), SammelFarbe() Dim i, ii, iii, x, m, n, y Dim z, s, farbklecks, txtQ For s = 1 To 30 Step 3 For z = 1 To 19 If Cells(z, s) = "" Then Exit For i = i + 1 ze(i) = z sp(i) = s Next z Next s s = Empty z = Empty i = Empty ReDim Arrii(199, 4) For iii = 1 To 200 Step 5 x = x For ii = (1 + iii - 1) To (5 + iii - 1) y = ii - iii z = ze(ii): s = sp(ii) If z = 0 Then Exit For If Cells(z, s) = "" Then Exit For txtQ = Cells(z, s).Text txtQ = Replace(txtQ, " ", "") Arrii(x, ii - iii) = txtQ Next ii x = x + 1 Next iii iii = Empty ii = Empty x = Empty txtQ = Empty ReDim SammelArr(199) For m = 0 To 199 For n = 0 To 4 SammelArr(m) = SammelArr(m) & Arrii(m, n) Next n Next m m = Empty ReDim SammelFarbe(199) For m = 0 To 199 If SammelFarbe(m) = "" Then SammelFarbe(m) = farbklecks + 1 End If For y = 1 To 199 - x If SammelArr(m) = SammelArr((m + y)) Then If SammelFarbe(m + y) = "" Then SammelFarbe(m + y) = farbklecks + 1 End If End If x = x + 1 Next y farbklecks = farbklecks + 1 Next m m = Empty n = Empty x = Empty y = Empty End Sub

Hi Onur, letztlich wird es ein Vergleich von Kalenderwochen werden. Das heißt der Rhytmus ist dann nicht 5 sondern 7. Ich möchte einfach nur im Kalender schnell nachvollziehen können, welche Wochen die selben Einträge (von Mo-Fr) haben, weil ich dann für meine Folgeroutinen weiß, welche Wochen ich einfach kopieren kann, weil ich sie mir schonmal vorgenommen habe und sich nichts geändert hat und welche (bei Abweichung) ich neu einstellen muss.
So: das ist der Hintergrund. Und das versuche ich nun mit dieser Hund-Katzen-Nummer einfach analog abzubilden. Ist mir mal wieder prächtig gelungen ^^.
Zu deiner Frage: das (Wiederholungen) könnte vorkommen. allerdings in deinem Beispiel nur so: "Hund, Katze, Maus, Hund, Katze" da die "Ratte, dann schon wieder in den nächsten 5'er Block fiele. Es soll strikt nach 5 Zellen ein Cut gemacht werden (1. Zeile im Array mit 5 Einträgen ist fertig) und die nächste Zeile begonnen. Und am dann einfach die Zeilen miteinander vergleichen.
Ich hoffe ich hab jetzt alle Klarheiten beseitigt :)?
lG
Toni

Private Sub CommandButton1_Click() Dim ze(1000) As Integer Dim sp(1000) As Integer Dim Arrii(), SammelArr(), SammelFarbe() Dim i, ii, iii, x, m, n, y Dim z, s, farbklecks, txtQ For s = 1 To 30 Step 3 For z = 1 To 19 If Cells(z, s) = "" Then Exit For i = i + 1 ze(i) = z sp(i) = s Next z Next s s = Empty z = Empty i = Empty ReDim Arrii(199, 4) For iii = 1 To 200 Step 5 x = x For ii = (1 + iii - 1) To (5 + iii - 1) y = ii - iii z = ze(ii): s = sp(ii) If z = 0 Then Exit For If Cells(z, s) = "" Then Exit For txtQ = Cells(z, s).Text txtQ = Replace(txtQ, " ", "") Arrii(x, ii - iii) = txtQ Next ii x = x + 1 Next iii iii = Empty ii = Empty x = Empty txtQ = Empty ReDim SammelArr(199) For m = 0 To 199 For n = 0 To 4 SammelArr(m) = SammelArr(m) & Arrii(m, n) Next n Next m m = Empty ReDim SammelFarbe(199) For m = 0 To 199 If SammelFarbe(m) = "" Then SammelFarbe(m) = farbklecks + 1 End If For y = 1 To 199 - x If SammelArr(m) = SammelArr((m + y)) Then If SammelFarbe(m + y) = "" Then SammelFarbe(m + y) = farbklecks + 1 End If End If x = x + 1 Next y If farbklecks > 50 Then farbklecks = farbklecks Else farbklecks = farbklecks + 1 End If Next m m = Empty n = Empty x = Empty y = Empty For i = 0 To 50 Step 5 x = x For n = 0 To 4 If ze(i + n) = 0 Then Exit For Cells(ze(i + n), sp(i + n) + 1).Interior.ColorIndex = SammelFarbe(x) Next n x = x + 1 Next i End Sub

Private Sub CommandButton1_Click() Dim ze(1000) As Integer Dim sp(1000) As Integer Dim Arrii(), SammelArr(), SammelFarbe() Dim i, ii, iii, x, m, n, y Dim z, s, farbklecks, txtQ For s = 1 To 30 Step 3 For z = 1 To 19 If Cells(z, s) = "" Then Exit For i = i + 1 ze(i) = z sp(i) = s Next z Next s s = Empty z = Empty i = Empty ReDim Arrii(199, 4) For iii = 1 To 200 Step 5 x = x For ii = (1 + iii - 1) To (5 + iii - 1) y = ii - iii z = ze(ii): s = sp(ii) If z = 0 Then Exit For If Cells(z, s) = "" Then Exit For txtQ = Cells(z, s).Text txtQ = Replace(txtQ, " ", "") Arrii(x, ii - iii) = txtQ Next ii x = x + 1 Next iii iii = Empty ii = Empty x = Empty txtQ = Empty ReDim SammelArr(199) For m = 0 To 199 For n = 0 To 4 SammelArr(m) = SammelArr(m) & Arrii(m, n) Next n Next m m = Empty ReDim SammelFarbe(199) For m = 0 To 199 If SammelFarbe(m) = "" Then SammelFarbe(m) = farbklecks + 3 End If For y = 1 To 199 - x If SammelArr(m) = SammelArr((m + y)) Then If SammelFarbe(m + y) = "" Then SammelFarbe(m + y) = farbklecks + 3 End If End If x = x + 1 Next y If farbklecks > 50 Then farbklecks = farbklecks Else farbklecks = farbklecks + 1 End If Next m m = Empty n = Empty x = Empty y = Empty For i = 0 To 50 Step 5 x = x For n = 1 To 5 If ze(i + n) = 0 Then Exit For Cells(ze(i + n), sp(i + n) + 1).Interior.ColorIndex = SammelFarbe(x) Next n x = x + 1 Next i End Sub

Private Sub CommandButton1_Click() Dim ze(1000) As Integer Dim sp(1000) As Integer Dim Arrii(), SammelArr(), SammelFarbe() Dim i, ii, iii, x, m, n, y Dim z, s, farbklecks, txtQ For s = 1 To 30 Step 3 For z = 1 To 19 If Cells(z, s) = "" Then Exit For i = i + 1 ze(i) = z sp(i) = s Next z Next s s = Empty z = Empty i = Empty ReDim Arrii(199, 4) For iii = 1 To 200 Step 5 x = x For ii = (1 + iii - 1) To (5 + iii - 1) y = ii - iii z = ze(ii): s = sp(ii) If z = 0 Then Exit For If Cells(z, s) = "" Then Exit For txtQ = Cells(z, s).Text txtQ = Replace(txtQ, " ", "") Arrii(x, ii - iii) = txtQ Next ii x = x + 1 Next iii iii = Empty ii = Empty x = Empty txtQ = Empty ReDim SammelArr(199) For m = 0 To 199 For n = 0 To 4 SammelArr(m) = SammelArr(m) & Arrii(m, n) Next n Next m m = Empty ReDim SammelFarbe(199) For m = 0 To 199 If SammelFarbe(m) = "" Then SammelFarbe(m) = farbklecks + 3 End If For y = 1 To 199 - x If SammelArr(m) = SammelArr((m + y)) Then If SammelFarbe(m + y) = "" Then SammelFarbe(m + y) = farbklecks + 3 End If End If x = x + 1 Next y If farbklecks > 50 Then farbklecks = farbklecks Else farbklecks = farbklecks + 1 End If y = Empty x = Empty x = m + 1 Next m m = Empty x = Empty y = Empty For i = 0 To 150 Step 5 x = x For n = 1 To 5 If ze(i + n) = 0 Then Exit For Cells(ze(i + n), sp(i + n) + 1).Interior.ColorIndex = SammelFarbe(x) Next n x = x + 1 Next i End Sub

Beliebteste Forumthreads (12 Monate)

Gleiche 5'er Kombinationen gleich einfärben

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Gleiche 5'er Kombinationen gleich einfärben

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread