VBA Code for Finding Cells Below which match the key - vba

Question

I have the following requirement I have 2 columns with unique keys called code. In one column below the code, there are one or multiple values present which is the answer. Like in below format
A X
1
2
B Y
9
3
Now the code will have a value populated in next column, while answers wont.
Now I have to find answers for all codes like A, B, C etc. For e.g If I compare with A then answer should be 1,2. I was writing a small subroutine as a beginning but I am facing issues. Can you please correct it
Sub CalculateCellValue()
Dim ValuesBelow As Variant
Dim ValuesRight As String
Dim rows1 As Integer
rows1 = 4
Dim colC As Integer
colC = 2
ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)
While (Not IsEmpty(ValuesRight))
ValuesBelow = ActiveSheet.Cells(rows1 + 1, colC)
rows1 = rows1 + 1
ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)
Wend
MsgBox (ValuesBelow)
End Sub

Answer 1

Purely for an ordered example as shown:
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet5") 'Change as appropriate
Dim myArr()
myArr = ws.Range("A1:B" & GetLastRow(ws, 1)).Value
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(myArr, 1) To UBound(myArr, 1)
If myArr(i, 2) <> vbNullString Then
If Not dict.exists(myArr(i, 1)) Then
Dim currKey As String
currKey = myArr(i, 1)
dict.Add myArr(i, 1), vbNullString
End If
Else
dict(currKey) = dict(currKey) & ", " & myArr(i, 1)
End If
Next i
Dim key As Variant
For Each key In dict
MsgBox key & " = " & Right$(dict(key), Len(dict(key)) - 1)
Next key
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function

Answer 2

I used below code to match my requirement
Function findBelowAll(rows1 As Long)
Dim ValuesBelow() As Variant
ReDim ValuesBelow(1 To 1) As Variant
Dim ValuesRight As Variant
Dim colC As Long
colC = 1
Dim i As Long
ValuesRight = ""
While (ValuesRight = "")
rows1 = rows1 + 1
' change / adjust the size of array
ReDim Preserve ValuesBelow(1 To UBound(ValuesBelow) + 1) As Variant
' add value on the end of the array
ValuesBelow(UBound(ValuesBelow)) =
Worksheets(ActiveSheet.Name).Cells(rows1, colC).Value
ValuesRight = Worksheets(ActiveSheet.Name).Cells(rows1, 2).Value
Wend
For i = LBound(ValuesBelow) To UBound(ValuesBelow) - 1
findBelowAll = findBelowAll & ValuesBelow(i) & vbNewLine
Next i
End Function