CODEWITHSUNDEEP
arraysvbaexcel
Zee_K
Zee_K

Reputation: 39

Run through multidimensional array and check data against a worksheet

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

Upvotes: 0

Views: 77

Answers (1)

Ambie
Ambie

Reputation: 4977

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

Upvotes: 1

Related Questions