VLOOKUP() Alternative using Arrays - arrays

I’ve been experimenting with arrays to find a faster alternative to VLOOKUP(), which can take a long time to execute with very large data sets.
I searched SO and many other sites, grabbing snippets of code.
The data:
A1:A5 the list of values to lookup (1,2,3,4,5)
C1:C5 the range to ‘find’ the values (2,4,6,8,10)
D1:D5 the range of values to ‘return’ (a,b,c,d,e)
B1:B5 is where I’d like to paste the ‘looked-up’ values.
The code works up to a point, in that it does return correct values for the ‘looked-up’ value’s position in C1:C5 – and the correct values in the adjacent cells in D1:D5.
When I try to load the returned values to Arr4 (the array to be pasted back to the sheet) which is saying <Type mismatch> when I hover the mouse over it. It doesn’t stop the code from executing, but it doesn’t paste anything.
My questions are:
How do I populate the array Arr4 with the myVal2 values, and
How do I paste it back to the sheet?
Option Explicit
Sub testArray()
Dim ArrLookupValues As Variant
ArrLookupValues = Sheet1.Range("A1:A5") 'The Lookup Values
Dim ArrLookupRange As Variant
ArrLookupRange = Sheet1.Range("C1:C5") 'The Range to find the Value
Dim ArrReturnValues As Variant
ArrReturnValues = Sheet1.Range("D1:D5") 'The adjacent Range to return the Lookup Value
Dim ArrOutput As Variant 'output array
Dim UpperElement As Long
UpperElement = UBound(ArrLookupValues) 'Used purely for the ReDim statement
Dim i As Long
For i = LBound(ArrLookupValues) To UBound(ArrLookupValues)
Dim myVal As Variant
myVal = ArrLookupValues(i, 1)
Dim pos As Variant 'variant becaus it can return an error
pos = Application.Match(myVal, ArrLookupRange, 0) 'pos always returns the correct position
Dim myVal2 As Variant
If Not IsError(pos) Then
myVal2 = ArrReturnValues(pos, 1) 'myVal2 always returns the correct value
ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
ArrOutput(i, 1) = myVal2
Else
ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
myVal2 = "Not Found"
ArrOutput(i, 1) = myVal2
End If
Next i
Dim Destination As Range
Set Destination = Range("B1")
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value =
ArrOutput
End Sub

According to #T.M 's answer, you can even do that without looping just by using VLookup instead of Match:
Public Sub testArraya()
With Sheet1
Dim ArrLookupValues() As Variant
ArrLookupValues = .Range("A1:A5").Value ' lookup values 1,2,3,4,5,6
Dim ArrLookupReturnRange() As Variant ' lookup range items 2,4,6,8,10
ArrLookupReturnRange = .Range("C1:D5").Value ' And return column D a,b,c,d,e
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] Match all values at once and return other values of column D
' (found position indices or Error 2042 if not found)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim ArrOutput() As Variant
ArrOutput = Application.VLookup(ArrLookupValues, ArrLookupReturnRange, 2, 0)
'[3] write results to any wanted target
Dim Destination As Range
Set Destination = Sheet1.Range("B1") ' ‹‹ change to your needs
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub
Or even extremly shortened and almost a one liner:
Public Sub testArrayShort()
Const nRows As Long = 5 'amount of rows
With Sheet1
.Range("B1").Resize(nRows).Value = Application.VLookup(.Range("A1").Resize(nRows).Value, .Range("C1:D1").Resize(nRows).Value, 2, 0)
End With
End Sub

Use proper error handling and an If statement instead of On Error Resume Next.
Also your Arr4 needs to be 2 dimensional like your other arrays. Even if it is only one column it needs no be Arr4(1 To UpperElement, 1 To 1) and Arr4(i, 1) = myVal2. Ranges are always 2 dimensional (row, column) even if there is only one column.
And I highly recommend to rename your array variables. When ever you feel like you have to give your variable numbers, you can be sure you are doing it wrong.
Rename them like following for example:
Arr1 --› ArrLookupValues
Arr2 --› ArrLookupRange
Arr3 --› ArrReturnValues
Arr4 --› ArrOutput
This is only a simple modification but your code will extremely gain in human readability and maintainability. You even don't need comments to describe the arrays because their names are self descriptive now.
Finally your output array can be declared the same size as the input arrays. Using ReDim Preserve makes your code slow, so avoid using it.
So something like this should work:
Option Explicit
Public Sub testArray()
Dim ArrLookupValues() As Variant
ArrLookupValues = Sheet1.Range("A1:A5").Value
Dim ArrLookupRange() As Variant
ArrLookupRange = Sheet1.Range("C1:C5").Value
Dim ArrReturnValues() As Variant
ArrReturnValues = Sheet1.Range("D1:D5").Value
Dim UpperElement As Long
UpperElement = UBound(ArrLookupValues, 1)
'create an empty array (same row count as ArrLookupValues)
ReDim ArrOutput(1 To UpperElement, 1 To 1)
Dim i As Long
For i = LBound(ArrLookupValues, 1) To UBound(ArrLookupValues, 1)
Dim FoundAt As Variant 'variant because it can return an error
FoundAt = Application.Match(ArrLookupValues(i, 1), ArrLookupRange, 0) 'pos always returns the correct position
If Not IsError(FoundAt) Then
ArrOutput(i, 1) = ArrReturnValues(FoundAt, 1)
Else
ArrOutput(i, 1) = "Not Found"
End If
Next i
Dim Destination As Range
Set Destination = Range("B1") 'make sure to specify a sheet for that range!
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub

Just for fun a slight modification of #PEH 's valid approach demonstrating a rather unknown way to excecute a single Match checking both arrays instead of repeated matches:
Public Sub testArray()
With Sheet1
Dim ArrLookupValues As Variant
ArrLookupValues = .Range("A1:A5").Value ' lookup values 1,2,3,4,5,6
Dim ArrLookupRange As Variant ' lookup range items 2,4,6,8,10
ArrLookupRange = .Range("C1:C5").Value
Dim ArrReturnValues As Variant ' return column D a,b,c,d,e
ArrReturnValues = .Range("D1:D5").Value
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] Match all item indices within ArrLookupRange at once
' (found position indices or Error 2042 if not found)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim ArrOutput
ArrOutput = Application.Match(ArrLookupValues, ArrLookupRange, 0)
'[2] change indices by return values
Dim i As Long
For i = 1 To UBound(ArrOutput)
If Not IsError(ArrOutput(i, 1)) Then
ArrOutput(i, 1) = ArrReturnValues(ArrOutput(i, 1), 1)
' Else
' ArrOutput(i, 1) = "Not Found" ' optional Not Found statement instead of #NV
End If
Next i
'[3] write results to any wanted target
Dim Destination As Range
Set Destination = Sheet1.Range("B1") '<< change to your needs
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub

Related

VBA Assigning Array to Range and Writing to Sheet returning all zeros

I am trying to assign an array to a range of values in an Excel sheet.
When I do though, even though using debug the array is not all zeros, it returns all zeros.
The weird thing is for the dat1 variable it does write to the cells correctly. Though that along with dat2 is an array of strings.
Thanks in advance.
Sub Comparor()
Dim dat1() As Variant
Dim dat2() As Variant
dat1() = Sheets("Data1").Range("E1:E10").Value2
dat2() = Sheets("Data2").Range("E1:E10").Value2
Dim iTemp As Integer
iTemp = CInt(UBound(dat1))
Dim NumMatches() As Integer
ReDim NumMatches(iTemp)
Dim iNum As Integer
Dim iCompareInner As Integer 'dat 2 cycler
Dim iCompareOuter As Integer 'dat 1 cycler
For iCompareOuter = 1 To UBound(dat1)
For iCompareInner = 1 To UBound(dat2)
If (dat1(iCompareOuter, 1) = dat2(iCompareInner, 1)) Then
NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1
End If
Next iCompareInner
Next iCompareOuter
Dim test22(10, 1) As Integer
For iNum = 1 To UBound(NumMatches)
'Debug.Print NumMatches(iNum)
test22(iNum, 1) = NumMatches(iNum)
Debug.Print test22(iNum, 1)
Next iNum
Sheets("Info").Range("E1:E10").Value2 = dat1
Sheets("Info").Range("F1:F10").Value2 = test22
Sheets("Info").Range("G1:G10").Value2 = NumMatches
End Sub
Count Matches (Dictionary, CountIf, Array (Double-Loop))
All three solutions do the same thing.
Using them with some serious data, e.g. 1K uniques on 100K values (means e.g. 100M iterations in the array version) will reveal the efficiency of each code.
But this is more about 2D one-based (one-column) arrays commonly used with (one-column) ranges.
The code is basic i.e. no blanks or error values are expected and each range has at least 2 cells
(i.e. Data = rg.Value with one cell doesn't work).
Option Explicit
Sub ComparorDictionary()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read values (duplicates)
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vData() As Variant: vData = vws.Range("E1:E10").Value
Dim vrCount As Long: vrCount = UBound(vData, 1)
' Count matches using a dictionary.
Dim vDict As Object: Set vDict = CreateObject("Scripting.Dictionary")
vDict.CompareMode = vbTextCompare
Dim vr As Long
For vr = 1 To vrCount
vDict(vData(vr, 1)) = vDict(vData(vr, 1)) + 1
Next vr
Erase vData ' values data is counted in the dictionary
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Write count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim ur As Long
For ur = 1 To urCount
If vDict.Exists(uData(ur, 1)) Then
uMatches(ur, 1) = vDict(uData(ur, 1))
End If
Next ur
Set vDict = Nothing ' data is in the unique arrays
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
Sub ComparorCountIf()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference values (duplicates). No array is needed.
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vrg As Range: Set vrg = vws.Range("E1:E10")
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Count matches and write the count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim ur As Long
For ur = 1 To urCount
uMatches(ur, 1) = Application.CountIf(vrg, uData(ur, 1))
Next ur
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
Sub ComparorArray()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read values (duplicates).
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vData() As Variant: vData = vws.Range("E1:E10").Value
Dim vrCount As Long: vrCount = UBound(vData, 1)
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Count matches and write the count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim vr As Long
Dim ur As Long
For ur = 1 To urCount
For vr = 1 To vrCount
If uData(ur, 1) = vData(vr, 1) Then
uMatches(ur, 1) = uMatches(ur, 1) + 1
End If
Next vr
Next ur
Erase vData ' data is in the unique arrays
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
As I said in my comment, one of your declarations is wrong and because of that, the unexpected result. Please, try understanding the next (didactic) code, to clarify the issue:
Sub testArray1D2D()
Dim arr1D, arr2DStrange, arr2D, i As Long
arr1D = Split("a,b,c,d,e,f,g,h,i,j", ",")
ReDim arr2DStrange(10, 1): ReDim arr2D(1 To 10, 1 To 1)
For i = 0 To UBound(arr1D)
arr2DStrange(i, 1) = arr1D(i)
arr2D(i + 1, 1) = arr1D(i)
Next i
Range("A2").Resize(UBound(arr2DStrange), 1).value = arr2DStrange 'it returns nothing
Range("B2").Resize(UBound(arr2DStrange), 2).value = arr2DStrange 'it returns what you need in the second column (D:D)
Range("D2").Resize(UBound(arr2D), 1).value = arr2D 'it returns correctly (what you need)
Range("E2").Resize(UBound(arr1D) + 1, 1).value = Application.Transpose(arr1D) 'also correct (a 1D array does not have any column! and it must be transposed. Otherwise, it repeats its first element value)
End Sub
When use declaration Dim test22(10, 1) As Integer it creates a 2D array but it has two columns. It is the equivalent of Dim test22(0 to 10, 0 to 1) As Integer. When you fill only the second column (1) and try returning the first one (0), this column, is empty.
The correct declaration for obtaining a 2D array with 10 rows and 1 column should be Dim test22(1 to 10, 1 to 1) As Integer.
Then, iTemp = CInt(UBound(dat1)) declares a 1D array of 11 elements (from 0, inclusive, to 10). And you never loaded its first element, starting iteration with 1. That's why the line Sheets("Info").Range("G1:G10").Value2 = NumMatches returned the first empty element 10 times... If your code would fill correctly the first element and if it was a matching one, your code will return 10 rows of 1 value.
NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1 is the equivalent of NumMatches(iCompareOuter) = 1. NumMatches(iCompareOuter) is always empty in that moment...
And it is good to cultivate the habit to avoid declarations As Integer in such a case. Working with Excel rows, the value of an Integer must be exceeded. Try using As Long. VBA is so designed to make the memory working in the same way, without any supplementary stress.
A more compact way to accomplish what you need will be the next approach:
Sub Comparor()
Dim dat1(), dat2(), NumMatches(), mtch, i As Long
dat1() = Sheets("Data1").Range("E1:E10").Value2
dat2() = Sheets("Data2").Range("E1:E10").Value2
ReDim NumMatches(1 To UBound(dat1), 1 To 1)
For i = 1 To UBound(dat1)
mtch = Application.match(dat1(i, 1), dat2, 0)
If IsNumeric(mtch) Then NumMatches(i, 1) = "OK"
Next i
Sheets("Info").Range("G1:G10").Value2 = NumMatches
End Sub
Not tested, but it should work. Except the case of a typo, when an error will be raised and sending some feedback I will rapidly correct...
This for example
Dim test22(10, 1) As Integer
in the absence of Option Base 1 is the same as
Dim test22(0 to 10, 0 to 1) As Integer
I'd use
Dim test22(1 to 10, 1 to 1) As Integer
if you want to match the arrays you read from the worksheet. Otherwise, dropping those arrays to a range only gives you the first "column" (which are all zeros since you never assigned anything there...)

Copy Multiple Non-Adjacent Columns To Array

I'm trying to copy multiple non-adjacent (non-contiguous) excel columns to an array but it's not working. Below is what I've tried...
Public Function Test()
Dim sh As Worksheet: Set sh = Application.Sheets("MyWorksheet")
Dim lr As Long: lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim r1 As Range: Set r1 = sh.Range("A1:A" & lr)
Dim r2 As Range: Set r2 = sh.Range("C1:C" & lr)
Dim rAll As Range: Set rAll = Union(r1, r2)
'Dim arr() As Variant: arr = Application.Transpose(rAll) <-- Throws Type mismatch error
'Dim arr As Variant: arr = Application.Transpose(rAll) <-- arr Value = Error 2015
Dim arr() As Variant: arr = rAll.Value2 ' <-- Only the first column (col A) is loaded.
End Function
Any help is greatly appreciated!
Since reading multiple values into an array like arr = rAll.Value2 is only possible in continous ranges, you have to alternatives:
Alternative 1:
Write a function that reads the range values area wise and merge it into one array.
Option Explicit
Public Function NonContinousColumnsToArray(ByVal NonContinousRange As Range) As Variant
Dim iArea As Long
For iArea = 1 To NonContinousRange.Areas.Count - 1
If NonContinousRange.Areas.Item(iArea).Rows.CountLarge <> NonContinousRange.Areas.Item(iArea + 1).Rows.CountLarge Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
Next iArea
Dim ArrOutput() As Variant
ArrOutput = NonContinousRange.Value2 'read first area into array
'read all other areas
For iArea = 2 To NonContinousRange.Areas.Count
ReDim Preserve ArrOutput(1 To UBound(ArrOutput, 1), 1 To UBound(ArrOutput, 2) + NonContinousRange.Areas.Item(iArea).Columns.CountLarge) As Variant 'resize array
Dim ArrTemp() As Variant 'read arrea at once into temp array
ArrTemp = NonContinousRange.Areas.Item(iArea).Value2
'merge temp array into output array
Dim iCol As Long
For iCol = 1 To UBound(ArrTemp, 2)
Dim iRow As Long
For iRow = 1 To UBound(ArrTemp, 1)
ArrOutput(iRow, UBound(ArrOutput, 2) - UBound(ArrTemp, 2) + iCol) = ArrTemp(iRow, iCol)
Next iRow
Next iCol
Next iArea
NonContinousColumnsToArray = ArrOutput
End Function
So the following example procedure
Public Sub ExampleTest()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArray(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
would take the following non-continous range Union(Range("A1:A9"), Range("C1:D9")) as input,
Image 1: The input range was non-continous A1:A9 and C1:D9.
merge it into one array OutputArr and write the values as follows
Image 2: The merged output array written back into cells.
Alterantive 2: Using a temporary worksheet …
… to paste the values as continous range, which then can be read into an array at once.
Public Sub ExampleTestTempSheet()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArrayViaTempSheet(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
Public Function NonContinousColumnsToArrayViaTempSheet(ByVal NonContinousRange As Range) As Variant
On Error Resume Next
NonContinousRange.Copy
If Err.Number <> 0 Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
On Error GoTo 0
Dim TempSheet As Worksheet
Set TempSheet = ThisWorkbook.Worksheets.Add
TempSheet.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
NonContinousColumnsToArrayViaTempSheet = TempSheet.UsedRange.Value2
Dim ResetDisplayAlerts As Boolean
ResetDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = ResetDisplayAlerts
End Function
Note that the alternative 2 is more likely to fail, because of the temporary worksheet. I think alternative 1 is more robust.
Alternative solution via Application.Index() function
Just for fun an alternative solution allowing even a resorted column order A,D,C:
Sub ExampleCall()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1]get data in defined columns order A,C,D
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim data: data = RearrangeCols(rng, "A,D,C")
'[2]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help functions called by above main procedure
Function RearrangeCols(rng As Range, ByVal ColumnList As String)
'Purpose: return rearranged column values based on ColumnList, e.g. Columns A,C,D instead of A:D
'[a]assign data to variant array
Dim v: v = rng
'[b]rearrange columns
v = Application.Index(v, Evaluate("row(1:" & UBound(v) & ")"), GetColNums(ColumnList)) ' Array(1, 3, 4)
'[c]return rearranged array values as function result
RearrangeCols = v
End Function
Function GetColNums(ByVal ColumnList As String, Optional ByVal Delim As String = ",") As Variant()
'Purpose: return array of column numbers based on argument ColumnList, e.g. "A,C,D" ~> Array(1, 3, 4)
'[a]create 1-dim array based on string argument ColumnList via splitting
Dim cols: cols = Split(ColumnList, Delim)
'[b]get the column numbers
ReDim tmp(0 To UBound(cols))
Dim i: For i = 0 To UBound(tmp): tmp(i) = Range(cols(i) & ":" & cols(i)).Column: Next
'[c]return function result
GetColNums = tmp
End Function
Further solution //Edit as of 2020-06-11
For the sake of completeness I demonstrate a further solution based on an array of arrays (here: data) using the rather unknown double zero argument in the Application.Index() function (see section [2]b):
data = Application.Transpose(Application.Index(data, 0, 0))
Sub FurtherSolution()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'[1]assign data to variant array
Dim v: v = rng
'[2]rearrange columns
'a) define "flat" 1-dim array with 1-dim column data A,C,D (omitting B!)
Dim data
data = Array(aCol(v, 1), aCol(v, 3), aCol(v, 4))
'=====================
'b) create 2-dim array
'---------------------
data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Function aCol(DataArr, ByVal colNo As Long) As Variant()
'Purpose: return entire column data as "flat" 1-dim array
With Application
aCol = .Transpose(.Index(DataArr, 0, colNo))
End With
End Function
Caveat: This 2nd approach seems to be less performant for greater data sets.
Related link
Some pecularities of the Application.Index() function
Thank you PEH,
Great explanation which led me to the following solution:
Function Test()
Dim sh as Worksheet : set sh = Sheets("MySheet")
Dim lr as Long : lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim arr () as Variant
Dim idx as Long
' Delete unwanted columns to ensure contiguous columns...
sh.Columns("B:B").Delete
' Load Array
arr = Sheet("MySheet").Range("A1:B" & lr).value2
' This allows speedy index finds... Note, index(arr, startrow, keycol)
' Will need to use "On Error" to handle key not being found
idx = WorksheetFunction.match("MyKey", WorksheetFunction.Index(arr, 0, 2), 0)
' And then fast processing through the array
For idx = idx to lr
if (arr(idx, 2) <> "MyKey") then exit for
' do some processing...
Next idx
End Function
Thank you again!
The idea behind using arrays is to increase speed. Moving and deleting columns, as well as "for" looping slows you down.
I'm looking for a way to speed up one of my procedures from 120,000 µs to 60,000 or less.
The proposed solutions slow it down to 450,000.

How do I copy this dynamic array into a spreadsheet and why don't boilerplate answers work for me?

I have written a VBA script to filter entries in an Excel table based on the contents of another one. I understand that although my table contains multiple fields (columns) they are contained within a 1D dynamic array.
I assigned a range in a workbook, and then resized this to reflect the size of the dynamic array. I then try to bulk assign the contents of the dynamic array to the range.
Sub generate_motor_list_from_QlikView_data()
Dim tags As Variant
Dim mtrs() As Variant
Dim msng() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim rng As Range
Dim mtrtbl As Range
ReDim Preserve mtrs(i)
ReDim Preserve msng(j)
tags = Worksheets("Backend").Range("Tags[Tag]")
For Each Tag In tags
Set rng = Worksheets("QlikView").Range("QlikView[Tag]").Find(What:=Tag, LookIn:=xlValues, LookAt:=xlWhole)
If rng Is Nothing Then
msng(j) = Tag
j = j + 1
ReDim Preserve msng(j)
' do something !
Else
Set mtrs(i) = Worksheets("QlikView").ListObjects("QlikView").ListRows(rng.Row - 1)
i = i + 1
ReDim Preserve mtrs(i)
End If
Next Tag
Set mtrtbl = Worksheets("Backend").Range("F18")
mtrtbl.Resize(UBound(mtrs, 1), 1) = mtrs
End Sub
The debugger brings up this message, on the line mtrtbl.Resize(UBound(mtrs, 1), 1) = mtrs
Run-time error '1004':
Application-defined or object-defined error"

Runtime error 9 "subscript out of range" array redim preserve vba

my code copies all the values of a table in excel on an array an filter them and fill a combobox with it, but I keep geting this error on my code and after debuging it's seems that the error is due to Redim Preserve ... can you check it please ?
' FIll CB2()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("D1")
Dim LC As Long
Dim i As Long
Dim PN As Long
Dim myArray() As String
Dim j As Long
Dim k As Long
Dim temp As String
LC = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = 1 To LC
If StrComp(CB1.List(CB1.ListIndex, 0), ws.Cells(i, 4), vbTextCompare) = 0 Then
'Set you array with the right dimension
ReDim Preserve myArray(0 To PN, 0 To 1)
myArray(PN, 0) = ws.Cells(i, 2)
myArray(PN, 1) = ws.Cells(i, 3)
PN = PN + 1
End If
Next i
End Sub
There is nothing to "Preserve" when the Redim statement is called for the first time in your loop. Call Redim without "Preserve" when you dimension the array for the first time.
If the line of code that dimensions variables is real code it is surprising that it doesn't call an error. I suggest to place each Dim statement in a line by itself, for better readability of the code if for no other reason, and avoid the use of the colon quite generally but especially for the purpose of mixing declarations with value assignment.

Assigning cell value to an array based on a condition

This is my first time using array in VBA. I was trying to check the value of my array based on certain condition.
I check my array value through the Locals Window. The window is empty. What did I do wrong?
Option Explicit
Sub test()
'define dynamic array
Dim sn As Variant
Dim i As Long
'Loop through all the row
For i = 1 To Rows.Count
If Cells(i, 12).Value = "Renewal Reminder" And Not IsEmpty(Cells(i, 12).Value) Then
'assign cell value to array
sn = Cells(i, 1).Value
Debug.Print "aaa" ' there are 8 cell values that meet the condition
End If
Next i
End Sub
Update
Dim sn as Varient was highlighted with Error
user-defined type not defined
Apart from the typo showing in the error message, you are not actually using sn as an array - you are simply storing each value in a scalar variable, replacing what was previously in that variable.
The following should work for you:
Option Explicit
Sub test()
'define dynamic array
Dim sn As Variant
Dim cnt As Long
Dim i As Long
ReDim sn(1 To 1)
cnt = 0
'Loop through all the row
For i = 1 To Cells(Rows.Count, "L").End(xlUp).Row
If Cells(i, 12).Value = "Renewal Reminder" Then
'assign cell value to array
cnt = cnt + 1
ReDim Preserve sn(1 To cnt)
sn(cnt) = Cells(i, 1).Value
Debug.Print "aaa" ' there are 8 cell values that meet the condition
End If
Next i
For i = 1 To cnt
Debug.Print sn(i)
Next
End Sub
As mentioned in the answer by Chemiadel, it is better to declare your variables using the appropriate base type if you know what that is.
So, if you know that column A contains text, replace Dim sn As Variant with
Dim sn() As String
or, if it is a double-precision number, use
Dim sn() As Double
etc. If column A could contain various different types, using Variant could be appropriate.
Note: You don't have to include the () when using Variant because Variant variables can switch happily between being scalars, arrays, objects, etc.
You need to declare Array with this way and avoid Variant data type :
Static Array : fixed-size array
dim sn(10) as String
Dynamic Array : you can size the array while the code is running.
dim sn() as String
Use ReDim Preserve to expand an array while preserving existing values
ReDim Preserve sn(UBound(sn) + 10)
Check the reference

Resources