20.03.2016, 11:27
Hallöchen,
ich hab mir auch gedacht, von unten zu beginnen. Allerdings komme ich in Zeile 8 auf 8, wenn ich den Bereich immer bis Zeile 1 durchsuche.
Also, gesucht ist die Zahl für AN8
Zeile 8: 22 ist offen, weil zuvor nicht markiert
Zeile 7: 11 ist belegt, weil zuvor in Zeile 4 markiert
Zeile 6: nichts zu prüfen
Zeile 5: 12 ist belegt, weil zuvor in Zeile 3 markiert
Zeile 5: 16 ist offen, weil zuvor nicht markiert
Zeile 4: nichts zu prüfen
Zeile 3: 11 wird nicht bewertet, weil weiter oben schon
Zeile 3: 19 ist offen, weil als Suchzahl nicht eingefärbt
Zeile 2 : 8 ist offen ...
Zeile 2 : 18 ist offen ...
Zeile 2: 12 wird nicht bewertet, weil weiter oben schon
Zeile 1: 3x offen, weils ja keine Zeile 0 gibt ...
Ich komme also auf 8x offen.
Das wäre der code dafür:
ich hab mir auch gedacht, von unten zu beginnen. Allerdings komme ich in Zeile 8 auf 8, wenn ich den Bereich immer bis Zeile 1 durchsuche.
Also, gesucht ist die Zahl für AN8
Zeile 8: 22 ist offen, weil zuvor nicht markiert
Zeile 7: 11 ist belegt, weil zuvor in Zeile 4 markiert
Zeile 6: nichts zu prüfen
Zeile 5: 12 ist belegt, weil zuvor in Zeile 3 markiert
Zeile 5: 16 ist offen, weil zuvor nicht markiert
Zeile 4: nichts zu prüfen
Zeile 3: 11 wird nicht bewertet, weil weiter oben schon
Zeile 3: 19 ist offen, weil als Suchzahl nicht eingefärbt
Zeile 2 : 8 ist offen ...
Zeile 2 : 18 ist offen ...
Zeile 2: 12 wird nicht bewertet, weil weiter oben schon
Zeile 1: 3x offen, weils ja keine Zeile 0 gibt ...
Ich komme also auf 8x offen.
Das wäre der code dafür:
Public Function CountColored3(iCalRow As Long) As Long 'Variablendeklarationen Dim cCount&, iCntC&, iCntR&, iColI& Dim rngCells As Range Dim bolTref As Boolean Dim colNumb As Collection, colRows As Collection Set colNumb = New Collection Set colRows = New Collection 'Funktion in Zeile 1 mit Wert 0 verlassen If iCalRow = 1 Then CountColored3 = 0: Exit Function 'Alle zu pruefenden Zahlen im Bereich O:Z aufnehmen Set rngCells = Range("O1:Z" & iCalRow) 'Zahlen aufnehmen With rngCells Redim arrColR(1 To .Rows.Count) 'Schleife ueber alle Zeilen des Bereichs For iCntR = .Rows.Count To 1 Step -1 iColI = colNumb.Count 'Schleife ueber alle Zellen des Bereiches For Each Zellen In .Rows(iCntR).Cells 'Wenn nix in der Zelle steht, dann Schleife verlassen 'und weiter mit naechster Zeile If Zellen.Value = "" Then Exit For 'Wenn der Farbindex <> keine Fuellung ist, dann Zahl uebernehmen If Zellen.Interior.Color <> Range("AO1").Interior.Color Then 'Bei Fehler weiter mit naechster Codezeile On Error Resume Next 'Zahl hinzufuegen, Fehler, wenn schon enthalten colNumb.Add Zellen.Value, CStr(Zellen.Value) 'Wenn kein Fehler, dann Zeilennummer merken If Err = 0 Then colRows.Add iCntR 'Fehlerbehandlung Ende On Error GoTo 0 'Oder Wenn der Farbindex = keine Fuellung ist, dann Else 'offene hochzaehlen cCount = cCount + 1 End If 'Ende Schleife ueber alle Zellen des Bereiches Next 'Ende Schleife ueber alle Zeilen des Bereichs Next End With 'Auszaehlen 'Schleife ueber alle collectioneintraege For iColI = 1 To colNumb.Count 'Wenn Zeilennumer = 1, dann 'In Zeile 1 sind alle offen If colRows(iColI) = 1 Then 'Wenn Zeilennumer = 1, dann cCount = cCount + 1 'Alternativ zu Wenn Zeilennumer = 1, dann Else 'Wenn Suchzahl nicht im Bereich ist, dann If WorksheetFunction.CountIf(Range("D1:I" & colRows(iColI) - 1), colNumb(iColI)) = 0 Then cCount = cCount + 1 Debug.Print colNumb(iColI) & vbTab & colRows(iColI) - 1 & vbTab & 0 'Alternativ zu Wenn Suchzahl nicht im Bereich ist, dann Else 'Schleife ueber alle Collectioneintraege For iCntR = colRows(iColI) - 1 To 1 Step -1 'Treffervariable auf false setzen bolTref = False 'Schleife ueber die Eintraege der Zeile in Spalten D:I For iCntC = 4 To 9 'Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann If Cells(iCntR, iCntC).Value = colNumb(iColI) And Cells(iCntR, iCntC).Interior.ColorIndex <> xlNone Then 'Treffervariable auf true setzen bolTref = True 'Schleife verlassen Exit For 'Ende Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann End If 'Ende Schleife ueber die Eintraege der Zeile in Spalten D:I Next 'Wenn Treffervariable true, dann Schleife verlassen If bolTref = True Then Exit For 'Ende Schleife ueber alle Collectioneintraege Next If bolTref = False Then cCount = cCount + 1 Debug.Print colNumb(iColI) & vbTab & colRows(iColI) - 1 & vbTab & 1 End If 'Ende Wenn Suchzahl nicht im Bereich ist, dann End If 'Ende Wenn Zeilennumer = 1, dann End If 'Ende Schleife ueber alle collectioneintraege Next 'Counter an Funktionswert geben CountColored3 = cCount End Function Sub test() MsgBox CountColored3(8) End Sub