Filter unique values

[FryGirl]

This VBA code returns the unique values from column A of the CURRENT tab. How could I also get the results of column B that go with the results from column A? I would like to put those results in Cells(2, 5).

Sub FilterLocation()
    
    Dim Dn As Range
    Dim rng As Range
    Dim ws  As Worksheet
    Set ws = Sheets("CURRENT")
    Set rng = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
    
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In rng
            If Not .Exists(Dn.Value) _
                And Dn.Offset(, 3).Value = Sheets("Sheet2").Range("B2").Value _
                And Dn.Offset(, 4).Value = Sheets("Sheet2").Range("B3").Value Then
                .Add Dn.Value, ""
            End If
        Next
        Sheets("Sheet2").Cells(2, 6).Resize(.Count).Value = Application.Transpose(.keys)
    End With
    
End Sub

 

[Fluff]

How about

Sub FilterLocation()
    
    Dim Dn As Range
    Dim rng As Range
    Dim ws  As Worksheet
    Set ws = Sheets("CURRENT")
    Set rng = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
    
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In rng
            If Not .Exists(Dn.Value) _
                And Dn.Offset(, 3).Value = Sheets("Sheet2").Range("B2").Value _
                And Dn.Offset(, 4).Value = Sheets("Sheet2").Range("B3").Value Then
                .Add Dn.Value, Dn.Offset(, 1).Value
            End If
        Next
        Sheets("Sheet2").Cells(2, 5).Resize(.Count, 2).Value = Application.Transpose(Array(.Items, .Keys))
    End With
    
End Sub

 

[FryGirl]

That works excellent, thanks.

 

[Fluff]

You're welcome & thanks for the feedback

 

[FryGirl]

H Fluff, I may have jumped the gun. I actually would like to return one other column. Ultimately, columns A, B, and C from the CURRENT tab and returned to D, E, and F on Sheet2

I added

.Add Dn.Value, Dn.Offset(, 1).Value, Dn.Offset(, 2).value

But this below I didn't know what to do with.

Sheets("Sheet2").Cells(2, 5).Resize(.Count, 2).Value = Application.Transpose(Array(.Items, .Keys))

Other then change to Cells(2, 4) and then (.Count, 3)

 

[Peter_SSs]

columns A, B, and C from the CURRENT tab and returned to D, E, and F on Sheet2

Try this modification (assuming that semicolons are not being used in cols B:C of 'CURRENT')

Sub FilterLocation()
   
    Dim Dn As Range
    Dim rng As Range
    Dim ws  As Worksheet
    Set ws = Sheets("CURRENT")
    Set rng = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
   
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In rng
            If Not .Exists(Dn.Value) _
                And Dn.Offset(, 3).Value = Sheets("Sheet2").Range("B2").Value _
                And Dn.Offset(, 4).Value = Sheets("Sheet2").Range("B3").Value Then
                .Add Dn.Value, Dn.Offset(, 1).Value & ";" & Dn.Offset(, 2).Value
            End If
        Next

        Sheets("Sheet2").Cells(2, 5).Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
        With Sheets("Sheet2")
          .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
        End With
         
    End With
   
End Sub

 

[FryGirl]

That's amazing Peter and it works grand. Thanks you.

 

[Peter_SSs]

You're welcome. Thanks for the confirmation.