Thema: Zahlen-Blöcke feststellen, zählen und formatieren

Hallo Excel Profis,
da stehe ich mal wieder wie der Ochse vor dem B...
Mit meinem Makro zähle ich alle 3er Blöcke (welche im Bereich <=21% liegen, nebeneinander sind), trage das Ergebnis in CP der entsprechenden Zeile ein.
Zudem wird der "3er Block" mit Hintergrundfarbe formatiert.
Klappt!
Will ich aber nun das selber mit 4er Blöcken machen; Klappt nicht!
Das funktionierende Makro:

Sub ZähleBlöcke_3er()

    Dim ws As Worksheet

    Dim rng As Range

    Dim values As Variant

    Dim numRows As Long

    Dim numCols As Long

    Dim i As Long, j As Long, k As Long

    Dim blockCount As Long

    Dim blockFlag As Boolean



    Set ws = ThisWorkbook.Sheets("Wertung")

    Set rng = ws.Range("F3:CO" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)

    values = rng.Value

    numRows = UBound(values, 1)

    numCols = UBound(values, 2)



    For i = 1 To numRows

        blockCount = 0

        For j = 1 To numCols - 2

            blockFlag = True

            If values(i, j) <= 0.21 And values(i, j + 1) <= 0.21 And values(i, j + 2) <= 0.21 Then

                If j > 1 Then

                    If values(i, j - 1) <= 0.21 Then

                        blockFlag = False

                    End If

                End If

                If j < numCols - 3 Then

                    If values(i, j + 3) <= 0.21 Then

                        blockFlag = False

                    End If

                End If

            Else

                blockFlag = False

            End If

            

            If blockFlag Then

                blockCount = blockCount + 1

                ' Hintergrundfarbe für die aktuellen Zellen setzen

                For k = 0 To 2

                    ws.Cells(i + 2, j + k).Interior.Color = RGB(255, 217, 102)

                Next k

                j = j + 2

            End If

        Next j

        ws.Cells(2 + i, "CP").Value = blockCount

    Next i

End Sub

und das nicht funktionierende:

Sub ZähleBlöcke_4er()

    Dim ws As Worksheet

    Dim rng As Range

    Dim values As Variant

    Dim numRows As Long

    Dim numCols As Long

    Dim i As Long, j As Long, k As Long

    Dim blockCount As Long

    Dim blockFlag As Boolean



    Set ws = ThisWorkbook.Sheets("Wertung")

    Set rng = ws.Range("F3:CO" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)

    values = rng.Value

    numRows = UBound(values, 1)

    numCols = UBound(values, 2)



    For i = 1 To numRows

        blockCount = 0

        For j = 1 To numCols - 3

            blockFlag = True

            If values(i, j) <= 0.21 And values(i, j + 1) <= 0.21 And values(i, j + 2) <= 0.21 And values(i, j + 3) <= 0.21 Then

                If j > 1 Then

                    If values(i, j - 1) <= 0.21 Then

                        blockFlag = False

                    End If

                End If

                If j < numCols - 4 Then

                    If values(i, j + 4) <= 0.21 Then

                        blockFlag = False

                    End If

                End If

            Else

                blockFlag = False

            End If

            

            If blockFlag Then

                blockCount = blockCount + 1



                For k = 0 To 3

                    ws.Cells(i + 2, j + k).Interior.Color = RGB(255, 217, 102)

                Next k

                j = j + 3 

            End If

        Next j

        ws.Cells(2 + i, "CP").Value = blockCount

    Next i



End Sub

Kann bitte ein Experte mal drauf schaun und mich auf den Fehler aufmerksam machen?!
https://www.herber.de/bbs/user/168618.xlsb


Gruss
Fred

Hallo,
so:

Sub BloeckeMarkieren()

  Dim vntArr, lngRow As Long, lngCol As Long, i As Integer

  Dim ws As Worksheet

  Dim blnBlock As Boolean, intBlock As Integer

  

  '*****************

  Const iCount = 3  'Anzahl aufeinander folgende, anpassen

  '*****************

  

  Set ws = Worksheets("Wertung")

  

  With ws

    With .Range(.Cells(4, 6), .Cells(Rows.Count, 1).End(xlUp).Offset(, 92))

      vntArr = .Value

      .Interior.Color = xlNone  'Farbe raus

    End With

  End With

  

  For lngRow = 1 To UBound(vntArr)

    lngCol = 1

    intBlock = 0

    Do While lngCol < UBound(vntArr, 2) - iCount + 1

      blnBlock = True

      For i = 0 To iCount - 1

        blnBlock = blnBlock And (vntArr(lngRow, lngCol + i) <= 0.21)

      Next i

      If blnBlock Then

        intBlock = intBlock + 1

        ws.Cells(lngRow + 3, lngCol + 5).Resize(, iCount).Interior.Color = RGB(255, 217, 102)

        lngCol = lngCol + iCount

      Else

        lngCol = lngCol + 1

      End If

    Loop

    ws.Cells(lngRow + 3, 94) = intBlock

  Next lngRow

End Sub

Gruß aus'm Pott
Udo

https://www.herber.de/bbs/user/168630.xlsb

Hallo

Oha, da gibt es schon vieele Antworten der Kollegen, ich habe sie noch nicht gelesen.
Lade aber mal meine Lösung hoch. Leider eine alte Excel 2003 Datei, das Makro wird dich überraschen.

Es befindet sich im Modul3, ist wesentlich kürzer als dein Makro, und wertet direkt -ALLE Blöcke aus-
Dabei fiel mir auf das es auch 6er und 7er Blöcke gibt. Was hier in den Spalten CP, CQ, CR angezeigt wird.
https://www.herber.de/bbs/user/168634.xls

Bei der Originaldatei fiel mir auf, das die Auswertung an mehreren Stellen nicht stimmt.
Und beim vierer Makro Zellen im Bereich Spalte A-D mit markiert werden. Das sollte nicht sein.

mfg Piet

Hallo Piet,
GENAU DAS! hatte ich als "Endergebnis" vor.
Große Klasse!!!
Ich habe mich (wie gewohnt) bei Onur und Udaah sehr umständlich mit der Anforderung ausgedrückt!

Vielen, Vielen Dank für deine Aufmerksamkeit und Kompetenz!

Das Makro werde ich aber erst am Donnerstag mir so richtig reinziehen .....

Nochmals vielen Dank

Gruss
Fred

Und MEINE letzte DAtei hast du dir nicht mal angesehen ????

Onur,
KLAR habe ich mir die angesehen und gespeichert, - um die am Donnerstag entsprechend "auszubauen (was mir anscheinend Piet nun abgenommen hat)
Ich werde dennoch mir beide Makros morgen ganz genau anschauen (um diese evt. noch weiter auszubauen)
Natürlich Dir Onur auch Vielen, vielen Dank für deine Mühe und Kompetenz!!

Ich muss nun aber wirklich hier raus,- bin total Platt

Gruss
Fred

Hallo Uduuh und Onur,
vielen Dank für eure Mühe!
Leider werden in beiden Versionen nicht die 4er Blöcke formatiert und gezählt.
Im Moment bin ich etwas fix&foxi
Melde mich morgen nochmals ....

Gruss
Fred

Häääh????
Und WAS ist DAS hier ?

du musst nur

  '*****************

  Const iCount = 3  'Anzahl aufeinander folgende, anpassen

  '*****************

beachten.

Gruß aus'm Pott
Udo

Hallo Onur,
ich wollte eigentlich - wie im Beispiel-Makro "ZähleBlöcke_3er", die Version in
ZähleBlöcke_4er
also; aller "zusammenhängende Zellen <21% zählen und formatieren. Bzw. alle 4er Blöcke.
Im ersten Makro "ZähleBlöcke_3er" bekomme ich das wie gewollt hin, aber die 4er Version ......

Gruss
Fred

Wo ist das Problem? Mein Makro (VIERER-BLÖCKE-VERSION) zählt und markiert Viererblöcke. Kopieren, Kleinigkeit ändern und du hast einen für 3er-Blöcke.

Onur, wir reden wohl aneinander vorbei

Es sollten nur die Werte UNTER 21 % markiert werden.
Das ist anscheinend wirklich ein großes Problem,- habe ja selbst über 2 Stunden vor dem Forumauftritt rumgebastelt .....
Obwohl das Makro "ZähleBlöcke_3er" so etwas wie eine Referenz darstellen sollte ....

Gruss
Fred

Sorry, hast Recht. Ich hab nur auf die Farben geachtet.
Es war nur ein kleiner Tippfehler:
https://www.herber.de/bbs/user/168633.xlsb

Jetzt mit Farbzurückstellung, wenn Werte verändert wurden.
https://www.herber.de/bbs/user/168635.xlsb