PDA

View Full Version : Extract Unique List That Meets Criteria



swaggerbox
12-06-2018, 04:44 AM
In column B, I have list of item numbers. I need to check if these item numbers have the value "12334". If it finds a match, extract its corresponding B value. However, column B items have duplicates. I only need the unique items.
In the example below, three rows meet the criteria (=12334), but I only need red and yellow (unique items). Take note the last row is also red. Output is on the last row of Sheet2

Sheet1
ColumnA ColumnB
red 12334
yellow 12334
blue 23455
red 12334

Sheet2
ColumnA
red
yellow

mancubus
12-06-2018, 07:43 AM
Sub vbax_64186_unique_list_from_filtered_rows()

Dim dict, itm
Dim cll as Range

Set dict = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
.AutoFilterMode = False
.Cells(1).AutoFilter 2, 12334
With .AutoFilter.Range
For Each cll In .Columns(1).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) 'exclude header row
'For Each cll In .Columns(1).SpecialCells(xlCellTypeVisible) 'include header row
itm = dict.Item(cll.Value)
Next
End With
.AutoFilterMode = False
End With

With Worksheets("Sheet2")
.Cells(1).CurrentRegion.ClearContents 'clear existing data, if any
.Cells(1).Resize(dict.Count) = Application.Transpose(dict.Keys)
End With

End Sub

大灰狼1976
12-06-2018, 07:12 PM
Private Sub test()
Dim arr, i&, dic As Object, r&
Set dic = CreateObject("scripting.dictionary")
arr = Sheets(1).[a1].CurrentRegion
For i = 1 To UBound(arr)
If arr(i, 2) = 12334 Then dic(arr(i, 1)) = ""
Next i
With Sheets(2)
If .Cells(1, 1) = "" Then r = 1 Else r = .[a65536].End(3).Row + 1
.Cells(r, 1).Resize(dic.Count) = Application.Transpose(dic.keys)
End With
End Sub

mana
12-14-2018, 06:42 PM
Sub test()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")

ws1.Rows(1).Resize(2).Insert
ws1.Range("A1:B1").Value = Array("T1", "T2") 'Dummy
ws1.Range("Z2").Formula = "=B2=12334" 'Criteria

ws1.Columns("A:B").AdvancedFilter xlFilterCopy, ws1.Range("Z1:Z2"), ws2.Range("A1"), True

ws1.Rows("1:2").Delete
ws2.Rows(1).Delete
ws2.Columns(2).Delete

End Sub