@tomhouy, this should do the trick...
Here's a UDF I've written that pulls data from multiple columns and displays the results into a single column [thanks to SeoTools' Dump()
!]. Call the function like this:
=Dump( RangeToColumn(
sourceRange [range : Required],
onlyUniques [boolean : Optional, default=False],
skipBlanks [boolean : Optional, default=True]
) )
- When
onlyUniques
= True
, duplicate cell values will be omitted
- When
skipBlanks
= True
, blank cells will be omitted
Error cells are automatically omitted and cell values are trimmed of extra spaces. To preserve the cells' original values, simply replace all instances of Trim(entry.Value)
with entry.Value
in the code below.
Public Function RangeToColumn(ByRef sourceRange As Range, _
Optional ByVal onlyUniques As Boolean = False, _
Optional ByVal skipBlanks As Boolean = True) As Variant
Dim valuesArray() As Variant, entry As Variant
Dim col As Range
Dim k As Long, colNum As Long, rowNum As Long
Dim dict As New Scripting.Dictionary
' TextCompareâșCase-Insensitive | BinaryCompareâșExact:
dict.CompareMode = TextCompare
Application.ScreenUpdating = False
k = 0
colNum = 0
rowNum = 0
On Error Resume Next
For Each col In sourceRange.Columns
colNum = colNum + 1
For Each entry In col.Cells
If Not IsError(entry) Then
rowNum = rowNum + 1
If (Trim(entry.Value) <> "" And entry.Value <> "n/a") _
Or Not skipBlanks Then
k = k + 1
ReDim Preserve valuesArray(1 To k)
valuesArray(k) = Trim(entry.Value)
dict(Trim(entry.Value)) = 1 'Save uniques to dictionary
End If
End If
Next entry
rowNum = 0
Next col
If onlyUniques Then
k = 1
For Each entry In dict.keys
ReDim Preserve valuesArray(1 To k)
valuesArray(k) = entry
k = k + 1
Next entry
End If
RangeToColumn = Application.Transpose(valuesArray)
Application.ScreenUpdating = True
End Function
I hope this helps!