Forum Discussion

Sandeeep's avatar
Sandeeep
Copper Contributor
Oct 13, 2022
Solved

TOCOL excel function, but as a UDF in VBA

TOCOL excel function, but as a UDF in VBA

ToCol is a function that takes a range and makes it all into one column, similarly toRow also exists.

 

So Excel has the TOCOL function!

Yay! It's exactly what I need.

 

In fact, I need 

=UNIQUE(TOCOL(A2:C7))
=SORT(UNIQUE(TOCOL(A2:C7)))
 
Here is the fun part, I can't use TOCOL, cause it doesn't exist in my version of Excel and is only in the beta as far as what I see, and I'm not an Office 365 user.
Basically this: https://answers.microsoft.com/en-us/msoffice/forum/all/tocol-excel-function-not-working/165a2807-2f5a-4b2d-995c-61e27dadd794
 
So Ok, I'm making ToCOL myself, via UDF.
I tried, but I failed. Please help.

 

Function TOCOLUMNS(SearchRange)

Set Search_Range = Range(SearchRange)
Dim Col_Values_Array() As Variant

i = 1
For Each cell In Search_Range
    If IsEmpty(cell) = False Then
        i = i + 1
        ReDim Col_Values_Array(1 To i, 1)
        Col_Values_Array(i, 1) = cell
    End If
Next

TOCOLUMNS = Col_Values_Array()

End Function

 

excel
Formulas and Functions
Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Oct 13, 2022

    Sandeeep 

    How about

    Function TOCOLUMNS(SearchRange As Range)
    Dim v As Variant
    Dim c As Variant
    Dim d As Object
    Dim i As Long
    Dim j As Long
    Dim t As Variant
    Set d = CreateObject("Scripting.Dictionary")
    v = SearchRange.Value
    For Each c In v
        If c <> "" Then
            d(c) = 1
        End If
    Next c
    v = d.Keys
    For i = LBound(v) To UBound(v) - 1
        For j = i + 1 To UBound(v)
            If v(i) > v(j) Then
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        Next j
    Next i
    TOCOLUMNS = Application.Transpose(v)
End Function

4 Replies

Sort By
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Oct 13, 2022

    Sandeeep 

    How about

    Function TOCOLUMNS(SearchRange As Range)
    Dim v As Variant
    Dim c As Variant
    Dim d As Object
    Dim i As Long
    Dim j As Long
    Dim t As Variant
    Set d = CreateObject("Scripting.Dictionary")
    v = SearchRange.Value
    For Each c In v
        If c <> "" Then
            d(c) = 1
        End If
    Next c
    v = d.Keys
    For i = LBound(v) To UBound(v) - 1
        For j = i + 1 To UBound(v)
            If v(i) > v(j) Then
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        Next j
    Next i
    TOCOLUMNS = Application.Transpose(v)
End Function
    • Sandeeep's avatar
      Sandeeep
      Copper Contributor
      Oct 21, 2022

      Thanks HansVogelaar 

       

      This code takes a range and turns it into a single column and adds Unique values.

      This is amazing, and what I needed.

       

      I tried editing the code, to make another function.

      Where, it just turns everything into a single column, even if its a duplicate.

      A simple Range into columns Function.

       

      I tried my best, but couldn't figure it out.

       

      My biggest struggle was the variables. As they were just single letters, I got massively confused and couldn't figure out what variable did what, and how they were used.

       

      If you are free, could you maybe use longer variable names, and add comments? It'll help me learn and make any changes if ever needed.

       

       

      Btw HansVogelaar 

      Completely unrelated to this Thread, but I see you help everyone and are super active too.

      Could you maybe help me out with my other question?

      https://techcommunity.microsoft.com/t5/excel/vba-optimization-help-for-large-string-manipulation-related-to/m-p/3658577

      • HansVogelaar's avatar
        HansVogelaar
        MVP
        Oct 21, 2022

        Sandeeep 

        And here is my previous code, with lots of comments added.

        Function TOCOLUMNS(SearchRange As Range)
    Dim v As Variant  ' Multi-purpose array
    Dim c As Variant  ' Element of array (corresponds to cell)
    Dim d As Object   ' Scripting.Dictionary object
    Dim i As Long     ' Loop index for bubble sort
    Dim j As Long     ' Idem
    Dim t As Variant  ' Placeholder for sort
    ' Create a Dictionary object
    Set d = CreateObject("Scripting.Dictionary")
    ' Store values of SearchRange in a two-dimensional array
    v = SearchRange.Value
    ' Loop through the array elements (cells)
    For Each c In v
        ' Only use non-blank values
        If c <> "" Then
            ' Set the dictionary entry with key c to 1
            ' If that entry doesn't exist yet, it will be created
            ' If it already existed, nothing will change
            ' This way, we collect the unique values
            d(c) = 1
        End If
    Next c
    ' Set v to the array of keys of the dictionary
    ' The array contains the unique values
    v = d.Keys
    ' Use the simple bubble sort algorithm to sort the array
    For i = LBound(v) To UBound(v) - 1
        For j = i + 1 To UBound(v)
            ' If an element is larger than a later element...
            If v(i) > v(j) Then
                ' ... then swap the elements
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        Next j
    Next i
    ' v is now an array laid out in a row
    ' Return the array transposed to a column
    TOCOLUMNS = Application.Transpose(v)
End Function

Resources