anbei mal der überarbeitete Code. Dauert nun nur noch 0,157 Sekunden, also ca. 10% Laufzeit gegenüber der ursprünglichen Version. Ich sammle die Gefärbten einer Zeile jetzt auch in einem String, weise den dann aber zeilenweise einer Collection zu und prüfe nur noch auf den Inhalt der Collection. Find nehme ich nicht, da nicht ausgeschlossen werden kann, dass eine Zahl im zu prüfenden Bereich gefärbt und ungefärbt enthalten ist. Das ist zumindest dann der Fall, wenn in AM1 nix steht. Das war im ersten Beispiel so und wurde bisher ja nicht ausgeschlossen, wenn ich nichts überlesen habe.
Modul mdl_schauan
OptionExplicit'Deklaration der API-Funktion PrivateDeclareFunction GetTickCount Lib"kernel32.dll" () AsLongPublicFunction CountColored4(ByVal iCalRow AsLong, colnumbers As Collection) AsLong'Konstante fuer Debug-Kontrolle Const debCnt AsInteger = 29'Variablendeklarationen 'Long Dim cCount&, iCntC&, iCntR&, iColI&, iRowF&
'Bereich Dim rngCells As Range, Zellen As Range
'Boolean Dim bolTref AsBoolean'Collections Dim colNumb As Collection, colRows As Collection
'Collection initialisieren Set colNumb = New Collection
Set colRows = New Collection
'Funktion in Zeile 1 mit Wert 0 verlassen If iCalRow = 1Then CountColored4 = 0: ExitFunction'Alle zu pruefenden Zahlen im Bereich O:Z aufnehmen Set rngCells = Range("O1:Z" & iCalRow)
'Zahlen aufnehmen With rngCells
'Array redimensionieren Redim arrColR(1To iCalRow)
'Schleife ueber alle Zeilen des Bereichs For iCntR = iCalRow To1Step -1
'Anzahl collectioneintraege in Variable speichern
iColI = colNumb.Count
'Schleife ueber alle Zellen des Bereiches ForEach Zellen In .Rows(iCntR).Cells
'Wenn nix in der Zelle steht, dann Schleife verlassen 'und weiter mit naechster Zeile If Zellen.Value = ""ThenExitFor'Wenn der Farbindex <> keine Fuellung ist, dann Zahl uebernehmen If Zellen.Interior.Color <> RGB(255, 204, 0) Then'Bei Fehler weiter mit naechster Codezeile OnErrorResumeNext'Zahl hinzufuegen, Fehler, wenn schon enthalten
colNumb.Add Zellen.Value, CStr(Zellen.Value)
'Wenn kein Fehler, dann Zeilennummer merken If Err = 0Then colRows.Add iCntR
'Fehlerbehandlung Ende OnErrorGoTo 0'Oder Wenn der Farbindex = keine Fuellung ist, dann Else'offene hochzaehlen
cCount = cCount + 1If iCalRow = debCnt ThenDebug.Print iCalRow & vbTab & Zellen.Value & vbTab & Zellen.Address & " offen / farblos in O:Z"EndIf'Ende Schleife ueber alle Zellen des Bereiches Next'Ende Schleife ueber alle Zeilen des Bereichs Next'Auszaehlen 'Schleife ueber alle collectioneintraege For iColI = 1To colNumb.Count
'Wenn Zeilennumer = 1, dann 'Wenn Zeile des Eintrags in O:Z in AM eingetragen ist, dann 'If WorksheetFunction.CountIf(Columns("AM"), colRows(iColI)) > 0 Then If Cells(1, "AM") > 0Then'Startzeile = Eintrag
iRowF = colRows(iColI)
'Alternativ Else'Startzeile = 1
iRowF = 1'Ende Wenn Zeile des Eintrags in O:Z in AM eingetragen ist, dann EndIf'Wenn Suchzahl nicht im Bereich ist, dann IfWorksheetFunction.CountIf(Range("D" & WorksheetFunction.Min(iRowF, iCalRow - 1) & ":I" & iCalRow - 1), colNumb(iColI)) = 0Then
cCount = cCount + 1If iCalRow = debCnt ThenDebug.Print iCalRow & vbTab & colNumb(iColI) & vbTab & colRows(iColI) & " offen / fehlt im Bereich D:I"'Alternativ zu Wenn Suchzahl nicht im Bereich ist, dann Else'Schleife ueber alle Zeilen For iCntR = iCalRow - 1ToWorksheetFunction.Min(iRowF, iCalRow - 1) Step -1
'Treffervariable auf false setzen
bolTref = False'Pruefzeile feststellen 'Schleife ueber die Eintraege der Zeile in Spalten D:I 'For iCntC = 4 To 9 'Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Zelle eingefaerbt ist, dann 'If Cells(iCntR, iCntC).Value = colNumb(iColI) And Cells(iCntR, iCntC).Interior.ColorIndex <> xlNone Then If InStr(1, colnumbers(iCntR), "#" & colNumb(iColI) & "#") > 0Then'Treffervariable auf true setzen If iRowF <> iCalRow Then bolTref = TrueIf iCalRow = debCnt ThenDebug.Print iCalRow & vbTab & colNumb(iColI) & vbTab & colRows(iColI) & vbTab & _
"Treffer in Zeile " & iCntR
'"Treffer in " & Cells(iCntR, iCntC).Address 'Schleife verlassen 'Exit For 'Ende Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Zelle eingefaerbt ist, dann EndIf'Ende Schleife ueber die Eintraege der Zeile in Spalten D:I 'Next 'Wenn Treffervariable true, dann Schleife verlassen If bolTref = TrueThenExitFor'Ende Schleife ueber alle Collectioneintraege Next'Wenn nix gefunden wurde, dann If bolTref = FalseThen'Offene-Zaehler hochsetzen
cCount = cCount + 1If iCalRow = debCnt ThenDebug.Print iCalRow & vbTab & colNumb(iColI) & vbTab & colRows(iColI) & " offen / farblos in D:I"'Ende Wenn nix gefunden wurde, dann EndIf'Ende Wenn Suchzahl nicht im Bereich ist, dann EndIf'Ende Schleife ueber alle collectioneintraege NextEndWith'Counter an Funktionswert geben
CountColored4 = cCount
EndFunctionSub AusZaehlen()
'Variablendeklarationen 'Long Dim iCnt&, lRow&, loStartTime&
'Collection Dim colnumbers As Collection
'Collection initialisieren Set colnumbers = New Collection
'Startzeit uebernehmen
loStartTime = GetTickCount
'Spalte AN (40) Leeren
Columns(40).ClearContents
'letzte Zeile mit Eintraegen >0 feststellen
lRow = WorksheetFunction.Max(Application.Evaluate("LOOKUP(2,1/(D1:D1000>0),ROW(D1:D1000))"), _
Application.Evaluate("LOOKUP(2,1/(E1:E1000>0),ROW(E1:E1000))"), _
Application.Evaluate("LOOKUP(2,1/(F1:F1000>0),ROW(F1:F1000))"), _
Application.Evaluate("LOOKUP(2,1/(G1:G1000>0),ROW(G1:G1000))"), _
Application.Evaluate("LOOKUP(2,1/(H1:H1000>0),ROW(H1:H1000))"), _
Application.Evaluate("LOOKUP(2,1/(I1:I1000>0),ROW(I1:I1000))"))
'Schleife bis zur letzten belegten Zeile <> 0 - Eintraege im Bereich D:I For iCnt = 1To lRow
'Wenn mindestens 3 Zellen gefaerbt sind, dann If CountColored(iCnt, colnumbers) >= 3Then'Wert fuer Spalte AN berechnen und eintragen
Cells(iCnt, 40) = CountColored4(iCnt, colnumbers)
'Ende Wenn mindestens 3 Zellen gefaerbt sind, dann EndIf'Ende Schleife bis zur letzten belegten Zeile (anhend Spalte D (4)) im Bereich D:I Next'Meldung Laufzeit in Sekunden aus Differenz von Systemzeit 'und Startzeit / 1000
MsgBox "Laufzeit " & _
(GetTickCount - loStartTime) / 1000 & " Sekunden.", _
vbInformation, "Application.Wait Soll: 3 Sekunden"EndSubPublicFunction CountColored(ByVal lRow AsLong, colnumbers As Collection) AsLong'Variablendeklarationen Dim Zellen, cCount&, rngCells As Range, strNumbers$
'Rueckgabewert 0 zuweisen
CountColored = 0'Zeilenbereich setzen Set rngCells = Cells(lRow, 4).Resize(1, 6)
'Anfang des String fuer Collection # zuweisen
strNumbers = "#"'wenn die Summe der Zeileneintraege gt. 0 ist, dann IfWorksheetFunction.Sum(rngCells) > 0Then'Schleife ueber alle Zellen des Bereiches ForEach Zellen In rngCells
'Wenn der Farbindex <> keine Fuellung ist, dann If Zellen.Interior.ColorIndex <> xlNone Then'Counter hochzaehlen
cCount = cCount + 1'Collection-Text erweitern
strNumbers = strNumbers & Zellen.Value & "#"'Ende Wenn der Farbindex <> keine Fuellung ist, dann EndIf'Ende Schleife ueber alle Zellen des Bereiches Next'Ende wenn die Summe der Zeileneintraege gt. 0 ist, dann EndIf'Collection erweitern
colnumbers.Add strNumbers, CStr(lRow)
'Counter an Funktionswert geben
CountColored = cCount
EndFunction
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
Folgende(r) 1 Nutzer sagt Danke an schauan für diesen Beitrag:1 Nutzer sagt Danke an schauan für diesen Beitrag 28 • Angelina
28.03.2016, 19:47 (Dieser Beitrag wurde zuletzt bearbeitet: 28.03.2016, 19:48 von atilla.)
Hallo Angelina,
kurze Zwischenfrage, darf man im Bereich AA:AL zusätzlich die Fundzeile für die gelben Zahlen reinschreiben, oder würde es Dein Konzept stören?
Da stehen ja bisher nur die Fundzeilen der grauen Zahlen.
Noch eine weitere Frage, gehe ich recht in der Annahme, dass der Code nie ausgeführt wird, wenn in AM1 kein Wert steht?
Zum Testen von Andres Code:
Das Testen mit >=0 macht meiner Meinung nach wenig Sinn, wenn überhaupt, dann mit >0. Könntest Du nicht so wie es ist noch einmal mal testen?
Am besten in der Datei, die uns auch zur Verfügung steht
@Andre
Andre nur kurz,später schreibe ich noch mal etwas dazu, ich hatte Deine zuletzt eingestellte Beispielmappe runter geladen und dort Deinen Code getestet.
Augenscheinlich waren es mehr als 5 Sekunden. Werde aber noch genaue Zahlen nachliefern.
Wenn in AM1 kein Wert steht, gehe ich davon aus, dass nichts gemacht wird, dazu habe ich Angelina ja befragt und ich gehe davon aus, dass sie meine Frage bejaht.
Dann brauch im bisher eingestellten Beispiel mit AM1 = 5 bis Zeile 19 grau gar nicht betrachtet werden.
Zitat:kurze Zwischenfrage, darf man im Bereich AA:AL zusätzlich die Fundzeile für die gelben Zahlen reinschreiben, oder würde es Dein Konzept stören?
Da stehen ja bisher nur die Fundzeilen der grauen Zahlen.
Kein Problem ... sehr gute Idee
Zitat:Zum Testen von Andres Code:
Das Testen mit >=0 macht meiner Meinung nach wenig Sinn, wenn überhaupt, dann mit >0. Könntest Du nicht so wie es ist noch einmal mal testen?
Am besten in der Datei, die uns auch zur Verfügung steht
'VBACode von Schauan
mit 700 Zeilen >=3 sind es bei mir: 3,198 Sekunden
mit 700 Zeilen >=0 sind es bei mir: 31 Sekunden
original Datei >=3 sind es bei mir: 0,281 Sekunden
Die Zweite Frage mit AM1 und Code ausführen ja oder nein steht offen.
Da es mit dem ergänzenden schreiben in AA:AL kein Problem ist, kann der Code noch einfacher uund schneller arbeiten.
Dazu müsse in XLPHAN's zwei Zeilen ergänzt werden.
Ich stell den überarbeiteten Code komplett ein, bitte in Deiner Datei austauschen:
Code:
Public Sub XLPHAN()
Dim lngLetzteZeile As Long
Dim lngSuchZeilenAnzahlMax As Long
Dim rngSuchwert As Range
Dim avntSuchwert() As Variant
Dim iavntSuchwert1 As Long
Dim iavntSuchwert2 As Long
Dim rngDaten As Range
Dim avntDaten() As Variant
Dim iavntDaten1 As Long
Dim iavntDaten2 As Long
For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
blnFund = True: Exit For
End If
Next
If blnFund Then Exit For
Next
If blnFund Then
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
blnFund = False
Else
Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
If Not rngFund Is Nothing Then
If rngFund.Interior.Color <> RGB(192, 192, 192) Then
rngFund.Interior.Color = vbYellow
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = rngFund.Row 'Zeile hinzugekommen
End If
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
Else
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = 10000 + lngLetzteZeile 'Zeile hinzugekommen
End If
End If
End If
Next
Set rngDaten = Nothing
Next
.Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
End With
Set rngDatenLastRow = Nothing
Set rngSuchwert = Nothing
End Sub
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function
Hinzugekommene Zeilen sind in Kommentaren kenntlich gemacht
Dann meinen Code mit folgendem austauschen:
Code:
Option Explicit
Public arr()
Dim lngMax As Long
Sub zählen_Ati()
Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x
Dim i As Long, j As Long
Dim strgSammlung As String
Dim vantQ As Variant
Dim loStartTime As Long
loStartTime = GetTickCount
Columns("N").Font.ColorIndex = xlAutomatic
For pp = 0 To lngMax - 1
For i = 1 To arr(pp) + 1
For j = 13 To 24
If vantQ(i, j) < 6 Then
If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
Else
If vantQ(i, j) > arr(pp) Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then
Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
For n = 1 To UBound(Split(strgSammlung, "#"))
x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
If IsNumeric(x) Then
lngP = n * 3 + n - 3
Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
End If
Next n
Else
Cells(arr(pp) + 1, 40) = 0
End If
strgSammlung = ""
Next pp
Erase arr
Dim lngLetzteZeile As Long
Dim i As Long, j As Long, k As Long, p As Long
Dim vntFeld_M
Dim vntFeld_A_O
Columns("M:N").ClearContents
Columns("AO").ClearContents
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
Range(Cells(1, 1), Cells(lngLetzteZeile, 3)).Interior.ColorIndex = xlColorIndexNone
vntFeld_M = Range(Cells(1, 13), Cells(lngLetzteZeile, 13))
vntFeld_A_O = Range(Cells(1, 41), Cells(lngLetzteZeile, 41))
For i = 1 To lngLetzteZeile
For j = 4 To 9
If Cells(i, j).Interior.ColorIndex <> xlColorIndexNone Then
k = k + 1
End If
Next j
If k >= 3 Then
ReDim Preserve arr(0 To p)
arr(p) = i - 1
p = p + 1
Cells(i, 41) = k
vntFeld_M(i, 1) = Application.Max(vntFeld_M) + 1
Range(Cells(i, 1), Cells(i, 3)).Interior.ColorIndex = 3
Else
vntFeld_A_O(i, 1) = k
End If
k = 0
Next i
lngMax = Application.Max(vntFeld_M)
Range(Cells(1, 13), Cells(lngLetzteZeile, 13)) = vntFeld_M
Range(Cells(1, 41), Cells(lngLetzteZeile, 41)) = vntFeld_A_O
End Function
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function
Ich stelle die Zeilen mit mehr als 2 Farben Fest und danach vergleiche ich keine Farben mehr, sondern schau in AA:AL wann die Zahl auftaucht.
Mein Pc scheint nicht so stark auf der Brust zu sein.
System: i7, 8GB RAM, W8.1-64, Off2007-32
Das sind meine Testergebnisse:
Arbeitsblatt mit dem Namen 'Tabelle3'
A
B
C
D
E
F
1
2
Ati alt
Ati mittelalt
Ati jung
Schauan alt
schauan jung
3
ActiveX Steuerelement
2,5
0,82
0,33
6,3
0,55
4
wenn mit Schaltfläsche aus Steuerelememten gestartet
2,5
0,82 - 0,81
0.3 -0,27
6,1 - 5,7
0,54 - 0,51
5
Letzte Zeile 209 der Daten
6
7
8
Jung bedeudet der jüngste Code, welcher aber im größeren Alter geschrieben wurde, leider!!!
29.03.2016, 06:50 (Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2016, 06:50 von Angelina.)
hallo atilla,
leider geht - mit dem neuen VBCode - bei mir für die Zeitmessung keine MsgBox auf.
Habe beide Teile von dir neu eingefügt.
Zitat:Die Zweite Frage mit AM1 und Code ausführen ja oder nein steht offen.
AM1 hat immer einen Wert
Dann ist mir mit dieser Version noch das aufgefallen - siehe Bild.
Im Bereich AA:AL hast du nun den Wert auch für die gelben eingetragen.
Jedoch diese Werte stimmen nicht!!!
Beispiel:
Zeile 22
gelbe 15
graue 39
Die graue 39 hat den Wert 3 ... das ist richtig ... ist in Zeile 24 gekommen
Die gelbe 15 hat den Wert 29 ... das ist falsch ... ist in Zeile 29 gekommen ... somit hätte sie eigentlich den Wert 8
mit der Zeitmessung klappte nicht, weil ich bei mir die Deklaration für die Funktion in einem anderen Modul als Public deklariert hatte
Du hättest unterhalb von Option Explicit diese Zeile ergänzen müssen:
Code:
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Spalte AN wurde verkappt gefüllt, da hast du recht.
Bei den Werten in AA:AL für gelb hatte ich die Zeilenzahl eintragen lassen unabhängig vom AM1 Wert.
Man kann es aber auch so, wie Du es haben möchtest.
Das habe ich jetzt mit folgenden Codes alles realisiert:
Code:
Public Sub XLPHAN()
Dim lngLetzteZeile As Long
Dim lngSuchZeilenAnzahlMax As Long
Dim rngSuchwert As Range
Dim avntSuchwert() As Variant
Dim iavntSuchwert1 As Long
Dim iavntSuchwert2 As Long
Dim rngDaten As Range
Dim avntDaten() As Variant
Dim iavntDaten1 As Long
Dim iavntDaten2 As Long
For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
blnFund = True: Exit For
End If
Next
If blnFund Then Exit For
Next
If blnFund Then
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
blnFund = False
Else
Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
If Not rngFund Is Nothing Then
If rngFund.Interior.Color <> RGB(192, 192, 192) Then
rngFund.Interior.Color = vbYellow
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = rngFund.Row - iavntSuchwert1 + 1 ' + lngSuchZeilenAnzahlMax 'Zeile hinzugekommen
End If
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
Else
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = 10000 + lngLetzteZeile 'Zeile hinzugekommen
End If
End If
End If
Next
Set rngDaten = Nothing
Next
.Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
End With
Set rngDatenLastRow = Nothing
Set rngSuchwert = Nothing
End Sub
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function
Code:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public arr()
Dim lngMax As Long
Sub zählen_Ati()
Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x
Dim i As Long, j As Long
Dim strgSammlung As String
Dim vantQ As Variant
Dim loStartTime As Long
loStartTime = GetTickCount
Columns("N").Font.ColorIndex = xlAutomatic
For pp = 0 To lngMax - 1
For i = 1 To arr(pp) + 1
For j = 13 To 24
If vantQ(i, j) < 6 Then
If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
Else
If vantQ(i, j) + i - 1 > arr(pp) Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then
Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
For n = 1 To UBound(Split(strgSammlung, "#"))
x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
If IsNumeric(x) Then
lngP = n * 3 + n - 3
Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
End If
Next n
Else
Cells(arr(pp) + 1, 40) = 0
End If
strgSammlung = ""
Next pp
Erase arr
Dim lngLetzteZeile As Long
Dim i As Long, j As Long, k As Long, p As Long
Dim vntFeld_M
Dim vntFeld_A_O
Columns("M:N").ClearContents
Columns("AO").ClearContents
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
Range(Cells(1, 1), Cells(lngLetzteZeile, 3)).Interior.ColorIndex = xlColorIndexNone
vntFeld_M = Range(Cells(1, 13), Cells(lngLetzteZeile, 13))
vntFeld_A_O = Range(Cells(1, 41), Cells(lngLetzteZeile, 41))
For i = 1 To lngLetzteZeile
For j = 4 To 9
If Cells(i, j).Interior.ColorIndex <> xlColorIndexNone Then
k = k + 1
End If
Next j
If k >= 3 Then
ReDim Preserve arr(0 To p)
arr(p) = i - 1
p = p + 1
vntFeld_M(i, 1) = Application.Max(vntFeld_M) + 1
Range(Cells(i, 1), Cells(i, 3)).Interior.ColorIndex = 3
End If
vntFeld_A_O(i, 1) = k
k = 0
Next i
lngMax = Application.Max(vntFeld_M)
Range(Cells(1, 13), Cells(lngLetzteZeile, 13)) = vntFeld_M
Range(Cells(1, 41), Cells(lngLetzteZeile, 41)) = vntFeld_A_O
End Function
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function
Wo die einzelnen Codes hinkommen weißt Du ja.
Zu Deiner weiteren Anfrage muss ich gestehen, dass ich es nicht verstanden habe.
Kannst Du es mit den mir vorliegenden Daten und mit Ergebnissen noch einmal versuchen zu erklären.
Aber mathematische Fachbegriffe kannst Du von mir auch nicht erwarten.
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
![[Bild: GelbeWerteInAA-AL.jpg?dl=0]](https://www.dropbox.com/s/puykhgymy0uuct1/GelbeWerteInAA-AL.jpg?dl=0)