Need VBA Code

yvsriravi12047 

It seems that I mistakenly provided an incorrect method name.

To achieve the desired result, you can use a Dictionary object in VBA to collect the unique values from the specified ranges. Here is an updated version of the code:

Sub GetUniqueValues()
    Dim ws6 As Worksheet
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
    Dim filterValue As Variant
    Dim resultDict As Object
    Dim result() As Variant
    Dim cell As Range
    Dim i As Long
    
    ' Set the worksheet references
    Set ws6 = ThisWorkbook.Worksheets("Sheet6")
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    Set ws4 = ThisWorkbook.Worksheets("Sheet4")
    
    ' Get the filter value from Sheet6 B3
    filterValue = ws6.Range("B3").Value
    
    ' Set the ranges based on the filter value
    If filterValue <> "" Then
        Set rng1 = ws1.Range("A:D").SpecialCells(xlCellTypeConstants)
        Set rng2 = ws2.Range("A:D").SpecialCells(xlCellTypeConstants)
        Set rng3 = ws3.Range("A:D").SpecialCells(xlCellTypeConstants)
        Set rng4 = ws4.Range("A:D").SpecialCells(xlCellTypeConstants)
    Else
        Set rng1 = ws1.Range("D:D").SpecialCells(xlCellTypeConstants)
        Set rng2 = ws2.Range("D:D").SpecialCells(xlCellTypeConstants)
        Set rng3 = ws3.Range("D:D").SpecialCells(xlCellTypeConstants)
        Set rng4 = ws4.Range("D:D").SpecialCells(xlCellTypeConstants)
    End If
    
    ' Create a Dictionary object to collect unique values
    Set resultDict = CreateObject("Scripting.Dictionary")
    
    ' Collect unique values from the ranges
    CollectUniqueValues rng1, resultDict
    CollectUniqueValues rng2, resultDict
    CollectUniqueValues rng3, resultDict
    CollectUniqueValues rng4, resultDict
    
    ' Sort the unique values
    result = SortDictionaryKeys(resultDict)
    
    ' Clear existing data in Sheet6 column A
    ws6.Range("A:A").ClearContents
    
    ' Write the unique values to Sheet6 column A
    For i = LBound(result) To UBound(result)
        ws6.Cells(i + 1, 1).Value = result(i)
    Next i
End Sub

Sub CollectUniqueValues(rng As Range, ByRef resultDict As Object)
    Dim cell As Range
    
    For Each cell In rng
        If Not resultDict.exists(cell.Value) Then
            resultDict.Add cell.Value, cell.Value
        End If
    Next cell
End Sub

Function SortDictionaryKeys(dict As Object) As Variant
    Dim keys() As Variant
    Dim i As Long
    
    ' Get the keys from the Dictionary
    keys = dict.keys
    
    ' Sort the keys
    QuickSort keys, LBound(keys), UBound(keys)
    
    SortDictionaryKeys = keys
End Function

Sub QuickSort(arr As Variant, low As Long, high As Long)
    Dim pivot As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    
    If low < high Then
        pivot = arr((low + high) \ 2)
        i = low - 1
        j = high + 1
        Do
            Do
i = i + 1
        Loop Until arr(i) >= pivot
        
        Do
            j = j - 1
        Loop Until arr(j) <= pivot
        
        If i < j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
        End If
    Loop While i < j
    
    If low < j Then QuickSort arr, low, j
    If i < high Then QuickSort arr, i, high
End Sub

The QuickSort subroutine is used to sort the array of keys obtained from the dictionary in ascending order. It utilizes the quicksort algorithm for efficient sorting.

With this complete code, you should be able (not tested) to run the GetUniqueValues macro to populate the unique values in Sheet6 column A based on the specified conditions.