Colour pattern matching

[KenTurner]

This is an Excel 2007 issue.

I have a table, Table_1, 6 columns wide, and variable in depth (currently just over 2000 rows deep).

Each cell in each row of Table_1 has an interior.color set to one of 5 preset values, Yellow, Light Blue, Grey, Green, Pink; colours within the row occur strictly in that order, and since there are five possible colours in six cells, there is always at least one duplicate. There can be up to 6 instances of the same colour in one row.

A second table, Patterns, is also 6 columns wide, but just 210 rows deep, and each row contains interior.colors conforming to the same rules as the rows in Table_1. Patterns contains all possible colour combinations and variations. The rows in this table are not in any particular order.

The object of the exercise is to match the colour pattern in each row of Table_1 with a row in Patterns, and return the row number within the Patterns table. The following code works fine, putting the result into column 7 of Table_1:

With [Tabel_1]
m = 0
For Each sRow In .Rows
m = m + 1
p = 0
For Each pRow In [patterns].Rows
p = p + 1
bFound = True
n = 0
For Each pCell In pRow.Cells
n = n + 1
bFound = bFound And (.Cells(m, n).Interior.Color = pCell.Interior.Color)
If Not bFound Then Exit For
Next pCell
If bFound Then
.Cells(m, 7) = p
Exit For
End If
Next pRow
Next sRow
End With

The problem with this solution is that it is relatively slow, due to the large number of iterations. I have spent a fair while trawling the VBA Help and tne Internet for other techniques, but drawn a blank. Can anybody come up with a suggestion?

A secondary issue, a solution to which could potentially speed up the operation a little, concerns the iteration counters (m, n and p in the above example). Is there any way, when using a for...each structure, of determining the row number relative to the top of the table, without using m, n and p? None of my tables starts in absolute row 1, and I need to be able to relocate them without breaking the code.

Incidentally, I coded it initially with simple for...next loops, but by experimentation discovered - somewhat to my surprise - that for...each loops were quicker - even with added iteration counters.

[Aussiebear]

Welcome to the VBAX forum Ken. To help save some time with future posts which include code, we use the hash tag to correctly indent all code. Simply select the code and select the Hash tag and all is done, or simply place (Code) (/Code) as surrounding tags. Looks like a great post of yours.

[KenTurner]

Thanks for the tip, Aussiebear.

[KenTurner]

Well, the silence has been deafening!

Has none of you VBA gurus anything to offer?

[mancubus]

help us help you by posting your workbook (replace any sensitive data).

Go Advanced
Manage Attachments
Add Files
Select Files (Select your file)
Open
Upload Files

[KenTurner]

As requested ...

[mancubus]

it took 1 second.
change worksheet name, ranges, row and column numbers to suit

Sub FindAndWriteColorPatterns_VBAX_52267()

    Dim ArrColors, ArrPattern(1 To 210)
    Dim r As Long, c As Long, calc As Long
    Dim ColorString As String
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    With Worksheets("VBA Test") 'change worksheet name to suit
        'write interior color values to cells
        For r = 3 To 212 'change start and end row numbers to suit
            For c = 10 To 15 'change start and end column numbers to suit
                .Cells(r, c) = .Cells(r, c).Interior.Color
            Next c
        Next r
    
        'load pattern cells' interior colors into 2D array
        ArrColors = .Range("J3:O212").Value 'change range to suit
        
        'create a 1D array, each element being concatenation of each 'row' of ArrColors
        For r = 1 To 210
            ArrPattern(r) = Join(Application.Index(ArrColors, r, 0), "|")
        Next r
    
        'since interior color values are stored in 2D array clear them
        .Range("J3:O212").ClearContents
        
        'clear existing match numbers, if any
        .Range("G3:G" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clear 'Last Cell in Col A must not be blank
        
        'write matches to Col G | No match returns #N/A
        For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Cell in Col A must not be blank
            ColorString = ""
            For c = 1 To 6
                ColorString = ColorString & .Cells(r, c).Interior.Color & "|"
            Next c
            ColorString = Left(ColorString, Len(ColorString) - 1) 'remove trailing "|" character added by last iteration
            .Cells(r, c) = Application.Match(ColorString, ArrPattern, 0)
        Next r
    End With

    With Application
        .EnableEvents = True
        .Calculation = calc
    End With

End Sub

[KenTurner]

Hey, mancubus, that looks pretty interesting.

Let me play with it some, and I'll post back later. Thanks for your efforts.

[KenTurner]

mancubus:

I've just timed my version at 11.57 seconds, and yours at 1.16 seconds.

Wow! that is impressive!

I've also looked through your technique, which is very neat, especially culminating in that final Match, which is a real showstopper.

Many thanks for showing me daylight here!

[KenTurner]

mancubus:

I think I have simplified your version a bit, but sadly it doesn't show any noticeable improvement in timing. Here's what it now looks like:

Option Explicit
Sub FindAndWriteColorPatterns_VBAX_52267()
     
    Dim ArrPattern(1 To 210) As String
    Dim r As Integer, c As Integer, calc As Integer
    Dim ColorString As String
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
     
    With Worksheets("VBA Test") 'change worksheet name to suit
       For r = 1 To 210 'change start and end row numbers to suit
            ArrPattern(r) = ""
            For c = 1 To 6 'change start and end column numbers to suit
                ArrPattern(r) = ArrPattern(r) & .Cells(r + 2, c + 9).Interior.Color & "|"
            Next c
        Next r
         
         'clear existing match numbers, if any
        .Range("G3:G" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clear 'Last Cell in Col A must not be blank
         
         'write matches to Col G | No match returns #N/A
        For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Cell in Col A must not be blank
            ColorString = ""
            For c = 1 To 6
                ColorString = ColorString & .Cells(r, c).Interior.Color & "|"
            Next c
            .Cells(r, c) = Application.Match(ColorString, ArrPattern, 0)
        Next r
    End With
     
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
    End With
End Sub

[mancubus]

then use unsimplified version.

btw, 11.57 seconds is not a long time. (i have some projects whose macros run for 3-4 hours.)