Unique list using first word in a string

Question

I have a 2 page spreadsheet with sheet 1 being reporting, sheet 2 being data. What I am trying to do is retrieve a unique list from the data sheet, column N and input it into the reporting sheet starting in cell B12 but I need the unique output list to be based on a keyword in cell B2 on the reporting page (In this case it is billy).

Also I would like it so that if the key word is changed from Billy to Horse, it will change the unique list from Billy to any strings starting with horse.

As this will be used by a few non tech users the simpler the better, ideally a VBA code I can throw into the back that they wont have to worry about would be ideal

Thanks

Answer 1

• Use Dictionary object to get the unique product list

Microsoft documentation:

Range.End property (Excel)

Range.ClearContents method (Excel)

Range.Resize property (Excel)

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, sWord As String
    Dim lastRow As Long, arrData
    Dim oSht1 As Worksheet, oSht2 As Worksheet
    Set oSht1 = Sheets("Sheet1")
    Set oSht2 = Sheets("Sheet2")
    sWord = oSht2.Range("B2")
    If Len(sWord) > 0 Then
        lastRow = oSht1.Cells(oSht1.Rows.Count, "N").End(xlUp).Row
        Set rngData = oSht1.Range("N1").Resize(lastRow)
        ' load data from Col N on sheet1
        arrData = rngData.Value
        Set objDic = CreateObject("scripting.dictionary")
        For i = LBound(arrData) + 1 To UBound(arrData)
            sKey = arrData(i, 1)
            ' get unique matched Product Desc list
            If StrComp(sWord, Left(sKey, Len(sWord)), vbTextCompare) = 0 Then
                If Not objDic.exists(sKey) Then
                    objDic(sKey) = ""
                End If
            End If
        Next i
        lastRow = oSht2.Cells(oSht2.Rows.Count, "B").End(xlUp).Row
        ' clear output range
        If lastRow > 12 Then oSht2.Range("B12:B" & lastRow).ClearContents
        ' write output to sheet
        oSht2.Range("B12").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
    End If
End Sub

---

Update:

Question:what I would have to add to the code so when the keyword is changed in B2 the code will automatically run

• Use Worksheet_Change() event code: Right click on sheet2's tab > View Code > paste the code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Address = "$B$2" And Len(.Cells(1).Value) > 0 Then
            Dim objDic As Object, rngData As Range
            Dim i As Long, sKey As String, sWord As String
            Dim lastRow As Long, arrData
            Dim oSht1 As Worksheet
            Set oSht1 = Sheets("Sheet1")
            sWord = .Value
            lastRow = oSht1.Cells(oSht1.Rows.Count, "N").End(xlUp).Row
            Set rngData = oSht1.Range("N1").Resize(lastRow)
            arrData = rngData.Value
            Set objDic = CreateObject("scripting.dictionary")
            For i = LBound(arrData) + 1 To UBound(arrData)
                sKey = arrData(i, 1)
                If StrComp(sWord, Left(sKey, Len(sWord)), vbTextCompare) = 0 Then
                    If Not objDic.exists(sKey) Then
                        objDic(sKey) = ""
                    End If
                End If
            Next i
            lastRow = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row
            Application.EnableEvents = False
            If lastRow > 12 Then Me.Range("B12:B" & lastRow).ClearContents
            If objDic.Count > 0 Then _
                Me.Range("B12").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
            Application.EnableEvents = True
        End If
    End With
End Sub