VBA to extract a unique list from Sheet 1 column N and list on sheet 2 column B based on a condition on sheet 1

Question

Tricky one here as I am not a coding expert.

• On sheet 1 column N I have a list of products

• Sheet 1 column D has the corresponding supplier number for column N products

• Sheet 2 cell B1 has the supplier number.

What I am after is a vba code that runs automatically when the supplier number is selected from the drop down in Sheet 2 cell B1, a unique list in generated from Sheet 1 column N based on a match in the supplier numbers from Sheet 1 column D, and place into B15.

Answer 1

• Use Dictionary object to get the unique product list
• Right click on sheet2 tab > View Code > paste the code

Microsoft documentation:

Dictionary object

Range.End property (Excel)

Range.ClearContents method (Excel)

Range.Resize property (Excel)

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Address = "$B$1" And Len(.Cells(1).Value) > 0 Then
            Dim objDic As Object, rngData As Range
            Dim i As Long, sKey As String, sSupp As String
            Dim lastRow As Long, arrData
            Dim oSht1 As Worksheet
            Set oSht1 = Sheets("Sheet1")
            sSupp = .Value
            lastRow = oSht1.Cells(oSht1.Rows.Count, "N").End(xlUp).Row
            Set rngData = oSht1.Range("D1:N" & lastRow)
            arrData = rngData.Value
            Set objDic = CreateObject("scripting.dictionary")
            For i = LBound(arrData) To UBound(arrData)
                sKey = arrData(i, 1) ' Col D [Supplier]
                If StrComp(sSupp, sKey, vbTextCompare) = 0 Then
                    objDic(arrData(i, 11)) = ""
                End If
            Next i
            ' Write Product list to sheet
            lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
            Application.EnableEvents = False
            If lastRow > 14 Then Me.Range("A15:A" & lastRow).ClearContents
            If objDic.Count > 0 Then Me.Range("A15").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
            Application.EnableEvents = True
        End If
    End With
End Sub

---

Update:

Question: If I was to use the code to transpose a list from a different column, eg column Z, instead of N

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Address = "$B$1" And Len(.Cells(1).Value) > 0 Then
            Dim objDic As Object, rngData As Range
            Dim i As Long, sKey As String, sSupp As String
            Dim lastRow As Long, arrData
            Dim oSht1 As Worksheet
            Const COL_SUPPLIER = 4 ' Col D
            Const COL_DATA = 14 ' Col N, 26 for Col Z
            Set oSht1 = Sheets("Sheet1")
            sSupp = .Value
            lastRow = oSht1.Cells(oSht1.Rows.Count, COL_SUPPLIER).End(xlUp).Row
            If COL_DATA > COL_SUPPLIER Then
                Set rngData = oSht1.Range("A1", oSht1.Cells(lastRow, COL_DATA))
            Else
                Set rngData = oSht1.Range("A1", oSht1.Cells(lastRow, COL_SUPPLIER))
            End If
            arrData = rngData.Value
            Set objDic = CreateObject("scripting.dictionary")
            For i = LBound(arrData) To UBound(arrData)
                sKey = arrData(i, COL_SUPPLIER) ' Col [Supplier]
                If StrComp(sSupp, sKey, vbTextCompare) = 0 Then
                    objDic(arrData(i, COL_DATA)) = ""
                End If
            Next i
            ' Write Product list to sheet
            lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
            Application.EnableEvents = False
            If lastRow > 14 Then Me.Range("A15:A" & lastRow).ClearContents
            If objDic.Count > 0 Then Me.Range("A15").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
            Application.EnableEvents = True
        End If
    End With
End Sub