CODEWITHSUNDEEP
vbaexcel
hsquared
hsquared

Reputation: 359

Return unique values which part match another criteria (Excel VBA)

I have a sheet of data on sheet1 which contains duplicates. On sheet 2 I have extracted a list of unique values with the Advanced Filter:

lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Data").Range("F2:F" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=NewSh2.Range("B4"), Unique:=True

This works fine however I would like it to only return values which partly match another cell (This is a drop down box in K2 - eg, if AA is selected in the box only values that start with AA are returned.)

I'm new to VBA and I'm not sure of the best way to go about doing this - (I had considered just deleting values which didn't match, which would create blanks, then to remove the blank rows - however I am concerned this would be a bit overkill and process heavy?) - is there a neater way to achieve this?

Thanks in advance!

Edit: Detail added.

So the dropdown in K2 has AA, BB, CC

The list of unique values looks something like:

 AA01
 AA02
 AA03
 BB02
 BB03
 AA05
 CC01
 CC02
 CC03
 CC05
 BB04

When the drop down has selected AA I would like the list to only return:

AA01
AA02
AA03
AA05

Upvotes: 0

Views: 348

Answers (2)

Luuklag
Luuklag

Reputation: 3914

You can just add your cell K2 from sheet Data as a criteria to your autofilter. Simply add the following piece to your code:

Criteria1:= Sheets("Data").Range("K2").value

This combines with your code to:

lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Data").Range("F2:F" & lr).AdvancedFilter Action:=xlFilterCopy, Criteria1:= Sheets("Data").Range("K2").value CopyToRange:=NewSh2.Range("B4"), Unique:=True

For some background reading see: https://www.thespreadsheetguru.com/blog/2015/2/16/advanced-filters-with-vba-to-automate-filtering-on-and-out-specific-values

Upvotes: 0

tigeravatar
tigeravatar

Reputation: 26640

Here's one way, using a dictionary:

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim NewSh2 As Worksheet
    Dim aFullList As Variant
    Dim hUnqMatches As Object
    Dim sMatch As String
    Dim i As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("Data")

    With wsData.Range("F2:F" & wsData.Cells(wsData.Rows.Count, "F").End(xlUp).Row)
        If .Row < 2 Then Exit Sub   'No data
        If .Cells.Count = 1 Then
            ReDim aFullList(1 To 1, 1 To 1)
            aFullList(1, 1) = .Value
        Else
            aFullList = .Value
        End If
    End With

    sMatch = wsData.Range("K2").Value
    Set hUnqMatches = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(aFullList, 1)
        If Left(aFullList(i, 1), Len(sMatch)) = sMatch Then
            If Not hUnqMatches.Exists(aFullList(i, 1)) Then hUnqMatches.Add aFullList(i, 1), aFullList(i, 1)
        End If
    Next i

    If hUnqMatches.Count > 0 Then
        On Error Resume Next
        Set NewSh2 = wb.Sheets("Sheet2")
        On Error GoTo 0
        If NewSh2 Is Nothing Then
            Set NewSh2 = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            NewSh2.Name = "Sheet2"
        End If
        NewSh2.Range("B4").Resize(hUnqMatches.Count).Value = Application.Transpose(hUnqMatches.Keys)
    End If

End Sub

Upvotes: 1

Related Questions