I have the following problem: I imported a .csv file with my data into a separate worksheet called "Import".
In this QueryTable, I have the second column called "KW", which indicates the weeknumber for every row.
Now I wanted to populate an array with the cell values from the second column.
I need to make it dynamic, because the length of the array changes with each import.
So far I made the code below:
Sub PopulatingArrayVariable()
Dim myArray() As Variant
Dim TempArray() As Variant
Dim myTable As ListObject
Dim x As Long
Sheets("Import").Activate
Set myTable = ActiveSheet.ListObjects("database_all")
TempArray = myTable.DataBodyRange.Columns(2)
myArray = Application.Transpose(TempArray)
For x = LBound(myArray) To UBound(myArray)
Debug.Print myArray(x)
Next x
End Sub
I get the "runtime error 13": types not compatible
I get the error, but I don't know what exactly I need to change. Can someone please help me solve this?
Fix the Dim and use Set:
Sub PopulatingArrayVariable()
Dim myArray() As Variant '*** will be a 1D VBA array
Dim TempArray As Range '*** typical 2D range variable as part of a column
Dim myTable As ListObject
Dim x As Long
Sheets("Import").Activate
Set myTable = ActiveSheet.ListObjects("database_all")
Set TempArray = myTable.DataBodyRange.Columns(2)
myArray = Application.Transpose(TempArray)
For x = LBound(myArray) To UBound(myArray)
Debug.Print myArray(x)
Next x
End Sub
I would use an arraylist instead as it provides more flexibility. For example you can do something like this:
Sub test()
Dim arr As Object
Dim i As Long
Dim j As Long
Dim lastRow As Long
Set arr = CreateObject("System.Collections.ArrayList")
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
j = 2
'Filling arrayLists
For i = 2 To lastRow
arr.Add ActiveSheet.Cells(i, 2)
Next i
'Read from arrayLists
For i = 0 To arr.Count - 1
Cells(j, 3) = arr(i)
j = j + 1
Next i
End Sub
Customize the code as required. It should resolve your issue.
Related
I have 2 arrays taken from 2 ranges in a sheet. I'm trying to create a third array that contains only the values contained in array 1 that are missing in array 2 (I found this code online).
Array 2´s size will vary and depends on this code:
Dim iListaIncompleta() As Variant
Dim iCountLI As Long
Dim iElementLI As Long
iCountLI = Range("B1").End(xlDown).Row
ReDim iListaIncompleta(iCountLI)
For iElementLI = 1 To iCountLI
iListaIncompleta(iElementLI - 1) = Cells(iElementLI, 2).Value
Next iElementLI
and Array 1's size is always from A1:A7, and I use this code to create it:
Dim iListaCompleta() As Variant
Dim iElementLC As Long
iListaCompleta = Range("A1:A7")
This is the original code I found online to extract missing values:
Dim v1 As Variant, v2 As Variant, v3 As Variant
Dim coll As Collection
Dim i As Long
'Original Arrays from the code:
v1 = Array("Bob", "Alice", "Thor", "Anna") 'Complete list
v2 = Array("Bob", "Thor") 'Incomplete list
Set coll = New Collection
For i = LBound(v1) To UBound(v1)
If v1(i) <> 0 Then
coll.Add v1(i), v1(i) 'Does not add value if it's 0
End If
Next i
For i = LBound(v2) To UBound(v2)
On Error Resume Next
coll.Add v2(i), v2(i)
If Err.Number <> 0 Then
coll.Remove v2(i)
End If
If coll.Exists(v2(i)) Then
coll.Remove v2(i)
End If
On Error GoTo 0
Next i
ReDim v3(LBound(v1) To (coll.Count) - 1)
For i = LBound(v3) To UBound(v3)
v3(i) = coll(i + 1) 'Collections are 1-based
Debug.Print v3(i)
Next i
End Sub
However, this code has arrays defined like this:
v1 = Array("Bob", "Alice", "Thor", "Anna")
And the actual arrays I wanna use are defined differently (as you can see in the first two pieces of code). When I try to run the code with them, it displays
Error 9: Subscript out of range.
The code works well as it originally is, but when I try to use MY arrays, it's when I get this error.
Obviously, I've tried it changing the names of the variables (v1 and v2) to my own 2 arrays (iListaCompleta and iListaIncompleta), and still doesn't work.
Any ideas??
Thank you in advance!
Here's a function that can be used to compare arrays of any dimension size to pull out differences and put only the differences in a one-dimensional array:
Public Function ArrayDifference(ByVal arg_Array1 As Variant, ByVal arg_array2 As Variant) As Variant
If Not IsArray(arg_Array1) Or Not IsArray(arg_array2) Then Exit Function 'Arguments provided were not arrays
Dim vElement As Variant
Dim hDifference As Object: Set hDifference = CreateObject("Scripting.Dictionary")
For Each vElement In arg_Array1
If Not hDifference.exists(vElement) Then hDifference.Add vElement, vElement
Next vElement
For Each vElement In arg_array2
If hDifference.exists(vElement) Then
hDifference.Remove vElement
Else
hDifference.Add vElement, vElement
End If
Next vElement
ArrayDifference = hDifference.Keys
End Function
Here's how you would call the function to compare two different arrays. It also includes how to populate the initial arrays using your provided setup:
Sub arrays()
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Dim rList1 As Range: Set rList1 = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim rList2 As Range: Set rList2 = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp))
Dim aList1 As Variant
If rList1.Cells.Count = 1 Then
ReDim aList1(1 To 1, 1 To 1)
aList1(1, 1) = rList1.Value
Else
aList1 = rList1.Value
End If
Dim aList2 As Variant
If rList2.Cells.Count = 1 Then
ReDim aList2(1 To 1, 1 To 1)
aList2(1, 1) = rList2.Value
Else
aList2 = rList2.Value
End If
Dim aList3 As Variant
aList3 = ArrayDifference(aList1, aList2)
MsgBox Join(aList3, Chr(10))
End Sub
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.
I am trying to assign values from column A to an array.
I want the size of the array to be dynamic. I want to loop through each cell and assign every cell value to my array.
Sub exercise3()
Dim asnwer
Dim output
Dim lastrow
Dim test
Dim i
Dim Data() As Variant 'Creating an dynamic array
Dim endnumber
lastrow = cells(Rows.Count, 1).End(xlUp).Row 'Find last row in column A
MsgBox (lastrow)
For i = 1 To lastrow
Data(i) = cells(i, "A").Value 'I want to assign each cell value to my array
Next i
MsgBox (Data(6))
Set output = cells(4, 4)
answer = WorksheetFunction.Average(Data)
output.Value = answer
End Sub
I get an error in my loop
"subscript out of range".
I have 14 rows in column A. If I declare the array with 14 positions/variables like this: Dim data (14), it is working. However I want it to be dynamic, so I can add/remove rows.
no loop needed just assign the whole to the array at once
Data = ActiveSheet.Range("A1:A" & lastrow).Value
Then the only thing you need to remember is that it is a 2 dimensional array with 1 column so:
msgbox Data(6,1)
Sub exercise3()
Dim asnwer As Double
Dim output As Range
Dim lastrow As Long
Dim Data() As Variant 'Creating an dynamic array
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Find last row in column A
MsgBox lastrow
Data = ActiveSheet.Range("A1:A" & lastrow).Value
MsgBox Data(6, 1)
Set output = ActiveSheet.Cells(4, 4)
answer = WorksheetFunction.Average(Data)
output.Value = answer
End Sub
I have a column with different values. I have to select only unique values from the column and put in an array.
I am using following code for the same but it puts unique values in another column rather array.
Sub GetUniqueSections()
Dim d As Object, c As Variant, i As Long, lastRow As Long
Dim a(8) As String
Dim j
Set d = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("C2:C" & lastRow)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("R2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
In the code below, UniqueValueArrayFromRange replaces your GetUniqueSections using the same technique with a Scripting.Dictionary. You can substitute "A1:A14" with whatever you need and the output array will be in arr:
Option Explicit
Sub Test()
Dim rng As Range
Dim arr As Variant
Dim i As Integer
' pass range values to function for unique values
Set rng = Sheet1.Range("A1:A14")
arr = UniqueValueArrayFromRange(rng)
' test return values
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
Function UniqueValueArrayFromRange(ByRef rngSource As Range) As Variant
Dim dic As Object
Dim rngCell As Range
' create dictionary and only add new values
Set dic = CreateObject("Scripting.Dictionary")
For Each rngCell In rngSource
If Not dic.Exists(rngCell.Value) Then
dic.Add rngCell.Value, 1
End If
Next rngCell
' return key collection as array
UniqueValueArrayFromRange = dic.Keys
End Function
Using Excel (2010) VBA, I am trying to copy (pass) a constant range of cells (whose values recalculate) to an array. Then I am trying to pass that array to a new range of cells, directly below it. After I have done this, I want to again copy (pass) the constant range's new values to the array, and pass these new values to a range directly below the one I previously passed.
I know this code is atrocious (I am new to arrays in VBA).
Sub ARRAYER()
Dim anARRAY(5) As Variant
Number_of_Sims = 10
For i = 1 To Number_of_Sims
anARRAY = Range("C4:G4")
Range("C4").Select
ActiveCell.Offset(Number_of_Sims, 0).Select
ActiveCell = anARRAY
Range("C4").Select
Next
End Sub
I sure do appreciate your help!
Thank you.
Respectfully,
Jonathan
You are off slightly on a few things here, so hopefully the following helps.
Firstly, you don't need to select ranges to access their properties, you can just specify their address etc. Secondly, unless you are manipulating the values within the range, you don't actually need to set them to a variant. If you do want to manipulate the values, you can leave out the bounds of the array as it will be set when you define the range.
It's also good practice to use Option Explicit at the top of your modules to force variable declaration.
The following will do what you are after:
Sub ARRAYER()
Dim Number_of_Sims As Integer, i As Integer
Number_of_Sims = 10
For i = 1 To Number_of_Sims
'Do your calculation here to update C4 to G4
Range(Cells(4 + i, "C"), Cells(4 + i, "G")).Value = Range("C4:G4").Value
Next
End Sub
If you do want to manipulate the values within the array then do this:
Sub ARRAYER()
Dim Number_of_Sims As Integer, i As Integer
Dim anARRAY as Variant
Number_of_Sims = 10
For i = 1 To Number_of_Sims
'Do your calculation here to update C4 to G4
anARRAY= Range("C4:G4").Value
'You can loop through the array and manipulate it here
Range(Cells(4 + i, "C"), Cells(4 + i, "G")).Value = anARRAY
Next
End Sub
No need for array. Just use something like this:
Sub ARRAYER()
Dim Rng As Range
Dim Number_of_Sims As Long
Dim i As Long
Number_of_Sims = 10
Set Rng = Range("C4:G4")
For i = 1 To Number_of_Sims
Rng.Offset(i, 0).Value = Rng.Value
Worksheets("Sheetname").Calculate 'replacing Sheetname with name of your sheet
Next
End Sub
Since you are copying tha same data to all rows, you don't actually need to loop at all. Try this:
Sub ARRAYER()
Dim Number_of_Sims As Long
Dim rng As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Number_of_Sims = 100000
Set rng = Range("C4:G4")
rng.Offset(1, 0).Resize(Number_of_Sims) = rng.Value
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
When i Tried your Code i got en Error when i wanted to fill the Array.
you can try to fill the Array like This.
Sub Testing_Data()
Dim k As Long, S2 As Worksheet, VArray
Application.ScreenUpdating = False
Set S2 = ThisWorkbook.Sheets("Sheet1")
With S2
VArray = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
End With
For k = 2 To UBound(VArray, 1)
S2.Cells(k, "B") = VArray(k, 1) / 100
S2.Cells(k, "C") = VArray(k, 1) * S2.Cells(k, "B")
Next
End Sub