Fill Listbox with Unique Values of Col

Private Sub ComboBox1_Change()
Dim xRg As Range
Dim xRgUni As Range
Dim xFirstAddress As String
Dim xStr As String
On Error Resume Next
xStr = ComboBox1.Value
Set xRg = Range("G1:H1").Find(xStr, , xlValues, xlWhole, , , True)
If Not xRg Is Nothing Then
xFirstAddress = xRg.Address
Do
Set xRg = Range("G1:H1").FindNext(xRg)
If xRgUni Is Nothing Then
Set xRgUni = xRg
Else
Set xRgUni = Application.Union(xRgUni, xRg)
End If
Loop While (Not xRg Is Nothing) And (xRg.Address  xFirstAddress)
End If
Dim cell As Range
Dim MyArr  As Variant, i As Long
' intialize array to high number of elements at start
ReDim MyArr(0 To 10000)
' work on sheets "mysheet" according to PO
With Sheets("mysheet")
For Each cell In xRgUni.EntireColumn.SpecialCells(xlCellTypeVisible)
MyArr(i) = cell.Value ' read all visible cells to array
i = i + 1
Next cell
' reduce array size to populated elements only
ReDim Preserve MyArr(0 To i - 1)
' populate listbox with array
ListBox3.List = RemoveDupesDict(MyArr)
End With
End Sub

Public Function RemoveDupesDict(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the dictionary method.
'NOTES: (1.a) You must add a reference to the Microsoft Scripting Runtime library via
' the Tools > References menu.
' (1.b) This is necessary because I use Early Binding in this function.
' Early Binding greatly enhances the speed of the function.
' (2) The scripting dictionary will not work on the Mac OS.
'SOURCE: https:// _
wellsr.com/vba/2017/excel/vba-remove-duplicates-from-array/
Dim i As Long
Dim d As Scripting.Dictionary
Set d = New Scripting.Dictionary
With d
For i = LBound(MyArray) To UBound(MyArray)
If IsMissing(MyArray(i)) = False Then
.item(MyArray(i)) = 1
End If
Next
RemoveDupesDict = .Keys
End With
End Function