filter unique values and sort A to Z Excel VBA

Question

I have been using below code to Filter the Unique values from Sheet1 and paste them into Sheet2 my code is working fine. But it has one issue that is when i remove any value from Sheet1.Range(C4:C) cell it gives empty cell in Sheet2 like in below image.

I want that if i remove any cell value from Sheet1 range then Code should automatically adjust it. there should not be any empty cell in Sheet2 Range.

I also wants to add sort function in the code so unique values will be popup with sorting A to Z in sheet2.

I tried at my end to do both things but cannot do. Your help in this regard will be highly appreciated.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet1.Range("C4:C" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
Sheet2.Range("C4").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

Answer 1

Copy Sorted Unique Column

• This solution uses a Dictionary for 'unique' and an Array List as a sorting option.
• In the current setup, as you change values in column C from cell C4 of Sheet1, the unique values appear sorted in column C from cell C4 of Sheet2.

Standard Module (e.g. Module1)

Option Explicit

Sub copySortedUniqueColumn( _
        SourceRange As Range, _
        DestinationCell As Range, _
        Optional ByVal doSort As Boolean = True)
    
    Dim Data As Variant
    If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
        Data = SourceRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = SourceRange.Value
    End If
    
    Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
    Dim Key As Variant
    Dim i As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i = 1 To UBound(Data, 1)
            Key = Data(i, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    If Not .Exists(Key) Then
                        .Item(Key) = Empty
                        arl.Add Key
                    End If
                End If
            End If
        Next i
        If .Count = 0 Then Exit Sub
    End With
    
    If doSort Then
        arl.Sort
    End If
    
    ReDim Data(1 To arl.Count, 1 To 1)
    i = 0
    For Each Key In arl
        i = i + 1
        Data(i, 1) = Key
    Next Key
    
    With DestinationCell
        .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        .Resize(i).Value = Data
    End With

End Sub

Function defineColumnRange( _
    FirstCellRange As Range) _
As Range
    On Error GoTo clearError
    If FirstCellRange Is Nothing Then GoTo ProcExit
    With FirstCellRange
        Dim cel As Range: Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If cel Is Nothing Then GoTo ProcExit
        Set defineColumnRange = .Resize(cel.Row - .Row + 1)
    End With
ProcExit:
    Exit Function
clearError:
    Resume ProcExit
End Function

Sheet Module (Sheet1)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const srcFirst As String = "C4"
    Const dstFirst As String = "C4"
    
    Dim srg As Range: Set srg = defineColumnRange(Range(srcFirst))
    If srg Is Nothing Then
        With Sheet2.Range(dstFirst)
            .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        End With
        Exit Sub
    End If
    
    Dim rg As Range: Set rg = Intersect(srg, Target)
    If rg Is Nothing Then Exit Sub
    
    Dim dCel As Range: Set dCel = Sheet2.Range(dstFirst)
    
    On Error GoTo clearError
    
    Application.EnableEvents = False
    copySortedUniqueColumn srg, dCel
SafeExit:
    Application.EnableEvents = True

Exit Sub

clearError:
    Resume SafeExit

End Sub

Answer 2

If you have O365, you can use a worksheet formula:

=UNIQUE(SORT(FILTER(Sheet10!$C$4:$C$10000,Sheet10!$C$4:$C$10000<>"")))

Replace Sheet1 with the actual name of your worksheet

Another VBA method, using the ArrayList object:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rg As Range, c As Range
    Dim AL As Object, vData As Variant, v As Variant, I As Long
    Dim ws2 As Worksheet
    
Set ws2 = Worksheets("sheet11") 'destination for paste operation
    
Set rg = Range(Cells(4, 3), Cells(Rows.Count, 3).End(xlUp))
If Not Intersect(rg, Target) Is Nothing Then
    Set AL = CreateObject("System.Collections.ArrayList")
    vData = rg 'fastest to work from vba array
    For I = 1 To UBound(vData)
        v = vData(I, 1)
        If Not v = "" And Not AL.contains(v) Then
            AL.Add v
        End If
    Next I
    
    AL.Sort
    
    'If might have more than 65,535 items, cannot use Transpose
    Application.ScreenUpdating = False
    ws2.Range("c4").Resize(Rows.Count - 4).ClearContents
    With ws2.Range("c4").Resize(AL.Count, 1)
        .Value = WorksheetFunction.Transpose(AL.toarray)
        .Range(.Cells(.Rows.Count, 1), .Cells(.Rows.Count, 1).End(xlUp)).ClearContents
    End With
    
End If

End Sub

Answer 3

This is the code I've used:

Sub test()
Dim WkSource As Worksheet
Dim WkDestiny As Worksheet
Dim MiMatriz() As Variant
Dim LR As Long
Dim i As Long
Dim ZZ As Long

Set WkSource = ThisWorkbook.Worksheets("source") 'Replace SOURCE with name of your Sheet1
Set WkDestiny = ThisWorkbook.Worksheets("destiny") 'Replace DESTINY with name of your sheet2

With WkSource
    LR = .Cells(.Rows.Count, 3).End(xlUp).Row 'Last non empty cell in colum C
    ReDim MiMatriz(1 To LR - 4 + 1) 'we do LR-4 because your data starts at row 4, and we add 1
    ZZ = 1
    For i = 4 To LR Step 1
        MiMatriz(ZZ) = .Range("C" & i).Value
        ZZ = ZZ + 1
    Next i
End With

'sort
Call QuickSort(MiMatriz, 1, UBound(MiMatriz))

'paste

'we paste array, excluding blanks
ZZ = 4 'starting at row 4
For i = 1 To UBound(MiMatriz) Step 1
    If MiMatriz(i) <> "" Then
        WkDestiny.Range("C" & ZZ).Value = MiMatriz(i)
        ZZ = ZZ + 1
    End If
Next i


'Remove duplicates
WkDestiny.Range("C4:C" & ZZ - 1).RemoveDuplicates Columns:=1, Header:=xlNo

Erase MiMatriz
Set WkSource = Nothing
Set WkDestiny = Nothing

End Sub

You'll need also this UDF to sort arrays:

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

My source sheet (your Sheet1) is:

And when executing code, in my destiny sheet (your sheet2) I get:

All data sorted and no blanks :)

Hope you can adapt this to your needs.

about function to sort arrays, all credits go to author: https://stackoverflow.com/a/152325/9199828