Counting and Then Notating a Color Pattern Within a Row

[AustinMaly]

After much digging, I don't know if what I'm looking for is possible or not. Its a reach for sure.

I am working on a knitting project, and it would be really helpful if I could get Excel to count the patterns in each for me. So far I have cells being conditionally formatted whether they are blank or if they contain an "X".

What i would like to know is: Can Excel count the Pattern and then notate the number of cells that have that specific color? Or is there an easier way to Flash Fill the pattern?

This is what i have as a base for my pattern:

Here are a couple options of what I'm HOPING achieve. I have tried to Flash Fill / Auto-Fill many of my rows as depicted for "Possible Option 3", but there are so many rows, and the patterns get kind of crazy, that its going to take me hours just to do this.

I hope this makes sense!

 

[Peter_SSs]

BTW, is that option the one you would prefer as the others are most likely possible too?

 

[AustinMaly]

BTW, is that option the one you would prefer as the others are most likely possible too?

Yes, I think this one will work out best for me, as it will be easier to just glance at the numbers as I go along!

 

[Peter_SSs]

Yes, I think this one will work out best for me,

OK, cheers.

The method that I used above (writing each result cell to the worksheet one at a time as it is calculated), by vba standards is quite slow. It shouldn't matter if the number of rows/columns in your data is not great. However if the data is large, or you just want a faster approach, you could also try this version (calculates all the results quickly in memory and then writes them all to the worksheet at once at the end).

Sub CountBlocks_v3()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, z As Long, uba2 As Long, lr As Long

  Const FirstRow As Long = 3              '<- Adjust to suit
  Const ColumnsToCheck As String = "A:T"  '<- Adjust to suit
  
  lr = Range(ColumnsToCheck).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  With Range(Replace(ColumnsToCheck, ":", FirstRow & ":") & lr)
    a = .Value
    uba2 = UBound(a, 2)
    ReDim b(1 To UBound(a), 1 To uba2)
    For i = 1 To UBound(a)
      k = 0
      j = 2
      z = 1
      Do
        If a(i, j) = a(i, j - 1) Then
          z = z + 1
        Else
          k = k + 1
          b(i, k) = z
          z = 1
        End If
        j = j + 1
      Loop Until j > uba2
      b(i, k + 1) = z
    Next i
    .Offset(, .Columns.Count + 1).Value = b
  End With
End Sub