VBA - How to get all values from fields in column B where corresponding fields are equal to a given value?

Question

My table is as below

ProjectID Item
A002 IT010
A002 IT021
A003 IT003
A002 IT010
A010 IT003
A010 IT010

The same project can have any number of items including duplicates.

Using vba, how can I get a list of all unique project ids in which each item was used.

This is the output I am looking for

Item IT010 was used in 2 projects - A002 and A010

My current code is as follows

Answer 1

Starting with data like:

Running this macro:

Sub Macro1()
    Dim N As Long, i As Long, c As Collection
    Dim K As Long, s As String, M As Long
    Dim j As Long
    Set c = New Collection
    Set c = Nothing
    Set c = New Collection
    Range("B:B").Copy Range("D1")

    ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlYes

    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("D:D")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    On Error Resume Next
    N = Cells(Rows.Count, "D").End(xlUp).Row
    M = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To N
        K = 5
        Set c = Nothing
        Set c = New Collection
        s = Cells(i, "D").Value
        For j = 2 To M
            If s = Cells(j, "B").Value Then
                c.Add Cells(j, "A").Value, CStr(Cells(j, "A").Value)
                If Err.Number = 0 Then
                    Cells(i, K).Value = Cells(j, "A").Value
                    K = K + 1
                Else
                    Err.Number = 0
                End If
            End If
        Next j
    Next i
    On Error GoTo 0
End Sub

will produce this:

Answer 2

This is something I wrote a long time ago with the same sort of idea in mind and it works wonderfully sweet:

Sub systemselector()

Dim BookM As Workbook
Dim ShtL As Worksheet, ShtM As Worksheet
Dim jj As Long, kk As Long, ii As Long, mm As Long
Dim ttt As String
Dim lrow As Long


Application.Calculation = xlCalculationManual
Set BookM = ActiveWorkbook
Set ShtL = BookM.Sheets("result") 'point to the sheet where you want results
Set ShtM = BookM.Sheets("data") ' point to the sheet name where you have the data


jj = 1

lrow = ShtM.Cells(ShtM.Rows.Count, "A").End(xlUp).Row    

For ii = 1 To 21 Step 1 'set the lowest and highest item number in your data set

    jj = jj + 1

    mm = 1

    ttt = "IT-" & Format(ii, "000")

    ShtL.Cells(mm, jj).Value = ttt

    For kk = 2 To lrow Step 1 '2 is the first row with info lrow is the last

    If ShtM.Range("B" & kk).Value = ttt Then 'checks if the item is in this line and if yes , records the associated project in the results sheet

        mm = mm + 1

        ShtL.Cells(mm, jj).Value = ShtM.Range("A" & kk).Value

        End If

    Next kk

Next ii

Application.Calculation = xlCalculationAutomatic



End Sub

In the end you should see a table with columns being your item IDs and line items under that header being associated projects. Let me know if this works, and if yes, please mark the answer as correct and good luck in your vba adventures :)