Need VBA Code

Question

&nbsp;This is very urgent requirement,&nbsp; please some one kindly help me on this.

nikolinode · Answer

yvsriravi12047&nbsp;If I may recommend, paste the code as text. as a picture you can't really see the blanks... and why does someone who wants to help have to rewrite the existing code to test it?At the same time I recommend you to add some more information. Information such as Excel version, operating system, storage medium. A precise description of the issue/problem, preferably a step-by-step description and possible messages, would also help "you".&nbsp;Thank you for your patience and understanding

yvsriravi12047 · Answer

Sure, Excel office 365, Windows 11 Laptop
Here is the formula i have used in excel:

=SORT(UNIQUE(IF($A$3="",(VSTACK(UNIQUE(FILTER('Sheet 1'!D:D,('Sheet 1'!D:D<>"Batch No")*('Sheet 1'!D:D<>""))),UNIQUE(FILTER('Sheet 2'!D:D,('Sheet 2'!D:D<>"Batch No")*('Sheet 2'!D:D<>""))),UNIQUE(FILTER('Sheet 3'!D:D,('Sheet 3'!D:D<>"Batch No")*('Sheet 3'!D:D<>""))),UNIQUE(FILTER('Sheet 4'!D:D,('Sheet 4'!D:D<>"Batch No")*('Sheet 4'!D:D<>""))))),
(VSTACK(UNIQUE(FILTER('Sheet 1'!D:D,('Sheet 1'!A:A=$A$3)*('Sheet 1'!D:D<>"Batch No")*('Sheet 1'!D:D<>""))),UNIQUE(FILTER('Sheet 2'!D:D,('Sheet 2'!A:A=$A$3)*('Sheet 2'!D:D<>"Batch No")*('Sheet 2'!D:D<>""))),UNIQUE(FILTER('Sheet 3'!D:D,('Sheet 3'!A:A=$A$3)*('Sheet 3'!D:D<>"Batch No")*('Sheet 3'!D:D<>""))),UNIQUE(FILTER('Sheet 4'!D:D,('Sheet 4'!A:A=$A$3)*('Sheet 4'!D:D<>"Batch No")*('Sheet 4'!D:D<>""))))))),1)

nikolinode · Answer

yvsriravi12047&nbsp;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 result As Variant
    Dim i As Long, j 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 &lt;&gt; "" 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
    
    ' Combine the ranges and get unique values
    result = Application.WorksheetFunction.Unique(Application.WorksheetFunction.VStack(rng1, rng2, rng3, rng4))
    
    ' Sort the unique values
    result = Application.WorksheetFunction.Sort(result, 1)
    
    ' Clear existing data in Sheet6 column A
    ws6.Range("A:A").ClearContents
    
    ' Write the unique values to Sheet6 column A
    For i = 1 To UBound(result, 1)
        ws6.Cells(i, 1).Value = result(i, 1)
    Next i
End SubThis code should work (untested) as long as you have Excel 365 or a version of Excel that supports dynamic arrays and the VStack and Unique functions. If you have an older version of Excel, you may need to use a different approach.I hope it helps!

yvsriravi12047 · Answer

NikolinoDE&nbsp;&nbsp;I am getting error like this&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;Please help me on this error&nbsp;

nikolinode · Answer

yvsriravi12047&nbsp;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 &lt;&gt; "" 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 &lt; high Then
        pivot = arr((low + high) \ 2)
        i = low - 1
        j = high + 1
        Do
            Do
i = i + 1
        Loop Until arr(i) &gt;= pivot
        
        Do
            j = j - 1
        Loop Until arr(j) &lt;= pivot
        
        If i &lt; j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
        End If
    Loop While i &lt; j
    
    If low &lt; j Then QuickSort arr, low, j
    If i &lt; high Then QuickSort arr, i, high
End Sub&nbsp;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.

Forum Discussion

Need VBA Code

Share

Resources