PDA

View Full Version : Colour pattern matching



KenTurner
04-12-2015, 01:18 PM
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
04-12-2015, 04:18 PM
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
04-13-2015, 03:31 AM
Thanks for the tip, Aussiebear.

KenTurner
04-16-2015, 07:58 AM
Well, the silence has been deafening!

Has none of you VBA gurus anything to offer?

mancubus
04-17-2015, 05:14 AM
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
04-17-2015, 06:13 AM
As requested ...

mancubus
04-17-2015, 12:56 PM
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
04-17-2015, 01:23 PM
Hey, mancubus, that looks pretty interesting.

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

KenTurner
04-18-2015, 05:04 AM
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
04-18-2015, 06:41 AM
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
04-18-2015, 03:38 PM
then use unsimplified version. :)

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