EN VI

Excel macro to compare adjacent cell value and highlight cell with same value in another column?

How to Excel macro to compare adjacent cell value and highlight cell with same value in another column

I have data of questions, choices & answers.

Col-A has questions and choices starting with question 1 and choices A,B,C,D. Similarly I have 500 questions and each has choices.

Col-B has questions & Col-C has correct answers.

I am trying to find the correct answer for each question in Column-B and Column-C, and then highlight the correct answer in Column-A for each question.

Example: If Question 1 in Col-B has correct answer as B in Col-C, then in Col-A, the question 1 correct choice B must be highlighted in Green color.

Similarly loop for all questions and answers in Col-B & Col-C and highlight all correct choices in Col-A

ColA     ColB   ColC  
1        1      B
A        2      A
B        3      A
C
D

2
A
B
C
D

3
A
B
C
D

Solution:

Use Dictionary object to track the location (row#) of question index .
The snippet can handle more choices. (eg. Q2 has 5 choices)

Microsoft documentation:

Dictionary object

Range.End property (Excel)

Interior.Color property (Excel)

Option Explicit

Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, iOffset As Long
    Dim arrData
    Set objDic = CreateObject("scripting.dictionary")
    ' Load data from Col A
    Set rngData = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    arrData = rngData.Value
    ' Loop through data
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1)
        If IsNumeric(sKey) Then
            objDic(sKey) = i
        End If
    Next i
    ' Clear color formatting on Col A
    Range("A:A").Interior.Color = xlNone
    ' Load data from Col B and C
    Set rngData = Range("B1:C" & Cells(Rows.Count, 2).End(xlUp).Row)
    arrData = rngData.Value
    ' Loop through data
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1)
        arrData(i, 2) = UCase(arrData(i, 2))
        If objDic.Exists(sKey) Then
            ' The distance between the choice and question index
            iOffset = Asc(arrData(i, 2)) - Asc("A") + 1
            ' Apply color formatting
            With Cells(objDic(sKey) + iOffset, 1)
                If UCase(.Value) = arrData(i, 2) Then _
                    .Interior.Color = vbGreen
            End With
        End If
    Next i
End Sub