Run through multidimensional array and check data against a worksheet - arrays

Question

Got an array which gets records the color of cells plus the ID associated with that row, which is specific to that row.
Now I want to run through the array picking up the ID and then using that to compare to another sheet (using the ID) to see if the color of the cell has changed.
I have tried to do this in a "hack" kind of way but I don't know how to step through each array record and pickup the ID extra to check.
Sub FindColourChange()
'this first bit is getting the data and putting in array
Dim newSheet As Worksheet
Dim r As Integer
Dim c As Integer
Set newSheet = ThisWorkbook.Worksheets("Combine")
intRowsNew = newSheet.UsedRange.Rows.Count
Dim newColourArray()
ReDim Preserve newColourArray(2 To intRowsNew, 7 To 19)
For r = 2 To intRowsNew ' this is the number of rows in your range
newColourArray(r, 7) = newSheet.Cells(r, 1).Value
Debug.Print "New is " & newColourArray(r, 7) & ", "
For c = 8 To 19
newColourArray(r, c) = newSheet.Cells(r, c).Interior.ColorIndex
Debug.Print "Colour of new is " & newColourArray(r, c) & ", "
Next
Next
'HERE IS WHERE I AM HAVING ISSUES - TRYING TO GET THE DATA FROM ARRAY TO COMPARE TO THE "Old Data" SHEET but cant figure a way out to go through each individual array record and get the first column value...
Dim result As String
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets("Old Data")
Dim currentRow As Integer
'result = Application.VLookup(newColourArray(r, 1), sheet.Range("A:S"), 8, False)
Sheets("Combine").Select
For r = 2 To newColourArray
Columns("A:A").Select
Selection.Find(What:=newColourArray(r, 7), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
currentRow = ActiveCell.Row
For c = 8 To 19
If newColourArray(r, c) <> oldSheet.Cells(currentRow, c).Interior.ColorIndex Then
Sheets("Combine").Select
End If
Next
Next
End Sub

Answer 1

Thanks for posting as a new question. I was thinking about it yesterday and the code below might do the trick for you:
Private Const ID_COLUMN As Integer = 1
Private Const FIRST_VALUE_COLUMN As Integer = 8
Private Const LAST_VALUE_COLUMN As Integer = 19
Private Type RowFields
ItemID As Variant
ColourOfValues(LAST_VALUE_COLUMN - _
FIRST_VALUE_COLUMN) As Variant
SheetRow As Long
End Type
Private mOldSheet As Worksheet
Private mNewSheet As Worksheet
Private mOldRowFields() As RowFields
Private mNewRowFields() As RowFields
Sub RunMe()
Set mOldSheet = ThisWorkbook.Worksheets("Old Data")
Set mNewSheet = ThisWorkbook.Worksheets("Combine")
' Read the desired values
ReadIDsColoursAndValues
' Acquire the cells where there's a colour change
AcquireColourChanges
End Sub
Private Sub ReadIDsColoursAndValues()
Dim firstRow As Integer
Dim lastRow As Integer
Dim r As Long
Dim c As Integer
Dim rowIndex As Long
Dim valueIndex As Integer
' ------------------
' Read the old sheet
' ------------------
' Define the row range
firstRow = 2 ' change this if different
lastRow = mOldSheet.Cells(mOldSheet.Rows.Count, 1).End(xlUp).Row
' Redimension the RowFields array
ReDim mOldRowFields(lastRow - firstRow) ' adjust if not zero-based
' Iterate through the rows to acquire data
For r = firstRow To lastRow
' Populate the row fields object
rowIndex = r - firstRow ' adjust if not zero-based
With mOldRowFields(rowIndex)
.ItemID = mOldSheet.Cells(r, ID_COLUMN).Value2
.SheetRow = r
' Iterate through the columns to acquire the colours
For c = FIRST_VALUE_COLUMN To LAST_VALUE_COLUMN
valueIndex = c - FIRST_VALUE_COLUMN ' adjust if not zero-based
.ColourOfValues(valueIndex) = _
mOldSheet.Cells(r, c).Interior.ColorIndex
Next
End With
Next
' ------------------
' Read the new sheet
' ------------------
' Define the row range
firstRow = 2 ' change this if different
lastRow = mNewSheet.Cells(mNewSheet.Rows.Count, 1).End(xlUp).Row
' Redimension the RowFields array
ReDim mNewRowFields(lastRow - firstRow) ' adjust if not zero-based
' Iterate through the rows to acquire data
For r = firstRow To lastRow
' Populate the row fields object
rowIndex = r - firstRow ' adjust if not zero-based
With mNewRowFields(rowIndex)
.ItemID = mNewSheet.Cells(r, ID_COLUMN).Value2
.SheetRow = r
' Iterate through the columns to acquire the colours
For c = FIRST_VALUE_COLUMN To LAST_VALUE_COLUMN
valueIndex = c - FIRST_VALUE_COLUMN ' adjust if not zero-based
.ColourOfValues(valueIndex) = _
mNewSheet.Cells(r, c).Interior.ColorIndex
Next
End With
Next
End Sub
Private Sub AcquireColourChanges()
Dim rowIndex As Long
Dim refIndex As Long
Dim rowItem As RowFields
Dim refItem As RowFields
Dim valueIndex As Integer
Dim sheetColumn As Integer
Dim highlightCells As Range
Dim cell As Range
For rowIndex = LBound(mNewRowFields, 1) To UBound(mNewRowFields, 1)
rowItem = mNewRowFields(rowIndex)
' Find the matching ID RowFields from old sheet
For refIndex = LBound(mOldRowFields, 1) To UBound(mOldRowFields, 1)
refItem = mOldRowFields(refIndex)
If rowItem.ItemID = refItem.ItemID Then
' Check each value colour against the old row
For valueIndex = LBound(rowItem.ColourOfValues, 1) To _
UBound(rowItem.ColourOfValues, 1)
If rowItem.ColourOfValues(valueIndex) <> _
refItem.ColourOfValues(valueIndex) Then
' Small piece of code to highligh the cells.
' You can do anything you like at this point.
sheetColumn = valueIndex + FIRST_VALUE_COLUMN ' adjust if not zero-based
Set cell = mNewSheet.Cells(rowItem.SheetRow, sheetColumn)
If highlightCells Is Nothing Then
Set highlightCells = cell
Else
Set highlightCells = Union(highlightCells, cell)
End If
End If
Next
' ID was found so we can break the search loop
Exit For
End If
Next
Next
mNewSheet.Activate
If highlightCells Is Nothing Then
MsgBox "No values have different colours."
Else
highlightCells.Select
MsgBox "The different coloured values have been highlighted." & vbCrLf & vbCrLf & _
highlightCells.Address(False, False)
End If
End Sub