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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2025 vBulletin Solutions Inc. All rights reserved.