trying to replicate the following in VBA to improve runtime (have 10s of thousands of rows)
I basically want to get the max value for each unique symbol
Already have the unique symbols, symbols and values as named ranges
Current array formula is
{=MAX(IF(symbols=D2, values, 0))}
for each cell
A VBA MaxIf (Formula)
Adjust the values in the constants section.
Option Explicit
Sub VBAMaxIf()
Const sAddress As String = "symbols"
Const vAddress As String = "values"
Const fRow As Long = 2
Const uCol As String = "D"
Const dCol As String = "E" ' adjust the destination (resulting) column!
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
If lRow < fRow Then Exit Sub ' no data
Dim urg As Range
Set urg = ws.Range(ws.Cells(fRow, uCol), ws.Cells(lRow, uCol))
Dim drg As Range: Set drg = urg.EntireRow.Columns(dCol)
Dim dFormula As String: dFormula = "=MAX(IF(" _
& ws.Range(sAddress).Address & "=" _
& ws.Cells(fRow, uCol).Address(0, 0) & "," _
& ws.Range(vAddress).Address & ",0))"
Application.Calculation = xlCalculationManual
drg.Formula = dFormula
drg.FormulaArray = drg.FormulaR1C1
drg.Value = drg.Value
Application.Calculation = xlCalculationAutomatic
End Sub
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
I am writing a code that defines a named range based on a different set of columns. These columns are identified by all having the word "Dashboard" written in the same row.
The code works right now if I specify the exact columns (see below "C,E,H,O") but I am lost on how to have the code collect all matching columns and then creating the ColumnList from it.
Option Explicit
Sub Define_Chart_Range()
Dim ws As Worksheet
Dim lastRow As Long
Dim arrColumns As Variant
Dim strSelect As String
Dim i As Integer
Dim lnRow As Long, lnCol As Long
Dim myNamedRange As Range
Dim myRangeName As String
Set ws = ThisWorkbook.Sheets("Data_Range")
'finding all columns that have the word Dashboard in Row 3
lnRow = 3
lnCol = ws.Cells(lnRow, 1).EntireRow.Find(What:="Dashboard", _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False).Column
'Find the last used row in Column A
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' Describe what columns you want to select
Const ColumnList As String = "C,E,H,O"
' Row to start at
Const StartAtRow As Long = 8
' Create an array to hold columns
arrColumns = Split(ColumnList, ",")
' Define first column to select
strSelect = arrColumns(0) & StartAtRow
' and add rows to last ne found above
strSelect = strSelect & ":" & arrColumns(0) & lastRow
' Add rest of columns to selection list
For i = 1 To UBound(arrColumns)
strSelect = strSelect & "," & arrColumns(i) & StartAtRow & ":" & arrColumns(i) & lastRow
Next i
' Defining name of Selected Columns as Named Range
Set ws = ThisWorkbook.Worksheets("Data_Range")
Set myNamedRange = ws.Range(strSelect)
'specify defined name
myRangeName = "Dashboard_Data"
'create named range with workbook scope. Defined name and cell range are as specified
ThisWorkbook.Names.Add Name:=myRangeName, RefersTo:=myNamedRange
End Sub
You can use Union to directly build a range, without needing to work with range addresses.
Sub Define_Chart_Range()
Const SearchRow As Long = 3
Const StartAtRow As Long = 8
Const RangeName As String = "Dashboard_Data"
Dim ws As Worksheet, lastRow As Long
Dim myNamedRange As Range, rng As Range, c As Range
Dim myRangeName As String
Set ws = ThisWorkbook.Sheets("Data_Range")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'loop cells in row to search...
For Each c In ws.Range(ws.Cells(SearchRow, 1), _
ws.Cells(SearchRow, Columns.Count).End(xlToLeft)).Cells
If LCase(c.Value) = "dashboard" Then 'want this column
'add to range
BuildRange myNamedRange, _
ws.Range(ws.Cells(StartAtRow, c.Column), ws.Cells(lastRow, c.Column))
End If
Next c
Debug.Print myNamedRange.Address
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=myNamedRange
End Sub
'utility sub to build up a range using Application.Union
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
I'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs
I have a code, that grabs data from a column of a file, and puts it into an array.
now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?
this is the code, and the array is at the end:
Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES
Remove the duplicates during the string construction by testing for prior existence with InStr function.
If Not IsEmpty(Cells(i, 1).Value) And _
Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
You should also remove the last trailing comma before splitting.
Next i
strSearch = Left(strSearch, Len(strSearch) - 1)
Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.
This worked for me:
Function removeDuplicates(ByVal myArray As Variant) As Variant
Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(myArray) To UBound(myArray)
d(myArray(i)) = 1
Next i
i = 0
For Each v In d.Keys()
ReDim Preserve outputArray(0 To i)
outputArray(i) = v
i = i + 1
Next v
removeDuplicates = outputArray
End Function
Hope it helps
Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then
strSearch = strSearch & "," & .Cells(i, 1).Value
End If
Next i
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)
Or even faster (as you won't have empty cells in the range after the RemoveDuplicates) :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
'NO MORE DUPLICATES and FASTER ARRAY FILL ;)
searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine.
You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.
Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object
set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
if dicUniques.exists(cells(i,1).value) = false then
dicUniques.add cells(i,1).value, cells(i,1).value
end if
End If
Next i
End With
s_wbk.Close
for each var in dicUniques.keys
strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")
That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first.
By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object.
Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.
edit: Corrected typo in the routine.
Unique Column To Array
Option Explicit
Sub removeDuplicates()
Const strFile = "...\Desktop\xl files min\src.xlsm"
Const SheetName As String = "Sheet1"
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim s_wbk As Workbook
Dim SourceArray, WorkArray, searchItem
Set s_wbk = Workbooks.Open(strFile)
SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
FirstRow, SourceColumn)
s_wbk.Close
If Not IsArray(SourceArray) Then Exit Sub
WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
searchItem = getUniqueArray(WorkArray)
End Sub
Function copyColumnToArray(SourceSheet As Worksheet, _
FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant
Dim rng As Range
Dim LastRowNumber As Long
Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
LookIn:=xlFormulas, Searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Function
Set rng = SourceSheet.Range(SourceSheet _
.Cells(FirstRowNumber, ColumnNumberLetter), rng)
If Not rng Is Nothing Then copyColumnToArray = rng
End Function
Function getUniqueArray(SourceArray As Variant, _
Optional Transpose65536 As Boolean = False) As Variant
' Either Late Binding ...
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' ... or Early Binding:
' VBE > Tools > References > Microsoft Scripting Runtime
'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
Dim i As Long
For i = LBound(SourceArray) To UBound(SourceArray)
If SourceArray(i) <> Empty Then
dict(SourceArray(i)) = Empty
End If
Next i
' Normal: Horizontal (Row)
If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
' Transposed: Vertical (Column)
If dict.Count <= 65536 Then _
getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
' Transpose only supports up to 65536 items (elements).
MsgBox "Source Array contains '" & dict.Count & "' unique values." _
& "Transpose only supports up to 65536 items (elements).", vbCritical, _
"Custom Error Message: Too Many Elements"
exitProcedure:
End Function