Oct 13 2022 01:52 AM
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
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
Oct 13 2022 03:26 AM
SolutionHow 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
Oct 21 2022 05:19 AM
Thanks @Hans Vogelaar
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 @Hans Vogelaar
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?
Oct 21 2022 06:04 AM
If you simply want to rearrange all non-empty cells in a range to a single column, here is a corrected version of your original function:
Function TOCOLUMNS(SearchRange)
Dim i As Long
Dim Col_Values_Array() As Variant
Dim cell As Range
' Loop through the cells of the range
For Each cell In SearchRange
' Only use non-empty cells
If cell.Value <> "" Then
' Increase count
i = i + 1
' Expand array without overwriting the existing values
ReDim Preserve Col_Values_Array(1 To i)
' Add the new value
Col_Values_Array(i) = cell
End If
Next
' Return the array transposed from row to column
TOCOLUMNS = Application.Transpose(Col_Values_Array)
End Function
Oct 21 2022 06:11 AM
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
Oct 13 2022 03:26 AM
SolutionHow 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