Extract unique values from column based on criteria

[acerlaptop]

Hi everyone,

I have a data that looks like this.

Column A Column B Column C
A 1
A 1
B 0
C 1
C 0
D 1

What the code does is that it paste values of Column A to Column C that passes a criteria w/c is "1".

What I want to do is remake the code so that Column C will be in a different worksheet (Sheet2) column A:A. Also the criteria will be from Sheet2 Cell A1. Also, column A:A is limited to 5 rows because row 6 onwards has values in it so if there are more, the code will insert another row, then will delete the extra rows if the values does not exceed row 5. (5 rows is the default)


Option Explicit

Sub Test()

Dim x As Variant
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")

With Sheet1
x = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(XlDirection.xlUp)).Value

For lngRow = 1 To UBound(x, 1)
If x(lngRow, 2) = 1 Then
objDict(x(lngRow, 1)) = 1
End If
Next

.Range(.Cells(1, 3), .Cells(objDict.Count, 3)).Value = Application.Transpose(objDict.Keys)
End With

Set objDict = Nothing
End Sub