Redim Preserve a 2D Array from Excel Table - arrays

Try as I might I cannot correct a "Subscript out of Range" error that the code below is throwing on the last line of code below when I try to expand the size of an array with Redim Preserve. Any ideas as to what might be wrong?
Sub Demo()
'Set Excel variables
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsCluster As Worksheet: Set wsCluster = wb.Worksheets("Cluster")
Dim initialK As ListObject: Set initialK = wsCluster.ListObjects("k")
'Set Array variables
Dim kArray() As Variant
ReDim kArray(1 To initialK.DataBodyRange.Rows.Count, 1 To initialK.DataBodyRange.Columns.Count)
kArray = initialK.DataBodyRange
'Set Other variables
Dim coordResults As Variant, kResults As Variant, addKs As Variant, dupeArray As Variant
Dim transferLat As Double, transferLong As Double, potDupeCount As Long, expandK As Long, nextAvailK As Long
'Run the assignment function once, then loop through average/assign functions
coordResults = Assign(coordArray, kArray)
For i = 1 To 3
kResults = Average(coordArray, kArray, coordResults)
coordResults = Assign(coordArray, kArray)
Next i
'Run the radius function
addKs = AdjustForRadius(coordArray, kResults, coordResults)
'Add the new, deduped centroid data to the kResults array
expandK = UBound(addKs, 1) + UBound(kArray, 1)
ReDim Preserve kArray(1 To expandK, 1 To 3)
End Sub
The functions are working properly. The "expand" variable is good.
I have tested everything I know.
Jake

Related

Error 9 displayed when using my own defined arrays in this code in VBA

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

Populating a dynamic array with cellvalues from one column VBA

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.

Create array of worksheets not variant

I would like to create an array of type worksheet, not variant, then populate the array using the Array function and finally pass the array to the worksheet.copy function to crate a new workbook of the worksheets in the array variables.
The following code works but none of the arrays are of type worksheet and two of the example arrays are populated with the worksheet names.
Dim wbkThis As Workbook
Dim wstX As Worksheet
Dim wstY As Worksheet
Dim wstZ As Worksheet
Dim arrWSA As Variant
Dim arrWSB() As Variant
Dim arrWSC(1 To 3) As Variant
Cancel = True
Set wbkThis = ThisWorkbook
Set wstX = wbkThis.Worksheets("SheetX")
Set wstY = wbkThis.Worksheets("SheetY")
Set wstZ = wbkThis.Worksheets("SheetZ")
ReDim arrWSA(1 To 3) As Variant
ReDim arrWSB(1 To 3) As Variant
arrWSA = Array(wstX, wstY, wstZ)
arrWSB = Array(wstX.Name, wstY.Name, wstZ.Name)
arrWSC(1) = wstX.Name
arrWSC(2) = wstY.Name
arrWSC(3) = wstZ.Name
arrWSA(1).Copy
Worksheets(arrWSB()).Copy
Worksheets(arrWSC()).Copy
While you can create an array of worksheets, it won't work to copy them all at once (though you could copy them in a loop). An array of names is the way to go if you want to copy multiple sheets at once.
Sub CopySheets()
Dim shtCount As Long: shtCount = Worksheets.Count
Dim X As Long
Dim arrSheets() As Worksheet: ReDim arrSheets(1 To shtCount)
For X = LBound(arrSheets) To UBound(arrSheets)
Set arrSheets(X) = Worksheets(X)
Next X
' Worksheets(arrSheets).Copy After:=Worksheets(shtCount) 'This won't work.
For X = LBound(arrSheets) To UBound(arrSheets)
arrSheets(X).Copy After:=Worksheets(shtCount) 'this will
Next X
Dim arrShtNames() As String: ReDim arrShtNames(1 To shtCount)
For X = LBound(arrShtNames) To UBound(arrShtNames)
arrShtNames(X) = Worksheets(X).Name
Next X
Worksheets(arrShtNames).Copy After:=Worksheets(shtCount) 'this will as well
End Sub

VBA Excel, shape array. How to fix the Error "Index Into The Specified Collection Is Out Of Bounds"?

In Excel I have three shapes namned ON_1, ON_2 and ON_3.
I am tring to build an array of Shape indexes and get the ShapeRange.
I have the VBA code but i get an error which says;
The index into the specified collection is out of bounds. Here is the code:
Sub test()
Dim sht As Worksheet
Dim shprng As ShapeRange
Dim shape_index As Variant
Dim i As Long
Set sht = ActiveSheet
ReDim shape_index(1 To sht.Shapes.Count)
For i = 1 To UBound(shape_index)
shape_index(i) = i
Next
Set shprng = sht.Shapes.Range(shape_index)
End Sub
I excpect to get variable shprng to include all the shapenames in the array.
But instead I get an error with this line of code:
Set shprng = sht.Shapes.Range(shape_index)
Run-time error 1004: The index into the specified collection is out of bounds
Any ideas?
You can use these fixes:
There's no need to use a heavy memory variant array. For your goal, a simple array of Integer will suffice.
Check if .Shapes.Count is 0, otherwise your code will not work
(Optional) The actual array size can be obtained with UBound(shape_index) - LBound(shape_index) + 1 (even if in this case it's not needed because you already know your lower bound)
With these corrections now it works. Here's the code:
Sub test()
Dim sht As Worksheet
Dim shprng As ShapeRange
Dim shape_index() As Integer
Dim i As Long
Set sht = ActiveSheet
'If no shape is present, exit sub
If sht.Shapes.Count = 0 Then Exit Sub
ReDim shape_index(1 To sht.Shapes.Count)
For i = 1 To UBound(shape_index) - LBound(shape_index) + 1
shape_index(i) = i
Next
Set shprng = sht.Shapes.Range(shape_index)
End Sub
Hope it helps.
Try this ...
Sub test()
Dim sht As Worksheet
Dim shprng As ShapeRange
Dim shape_index() As Variant
Dim i As Long
Set sht = ActiveSheet
ReDim shape_index(1 To sht.Shapes.Count)
For i = 1 To UBound(shape_index)
shape_index(i) = i
Next
Set shprng = sht.Shapes.Range(shape_index)
End Sub
This line ...
Dim shape_index As Variant
... was your problem. It wasn't originally declared as an array.
It's now this ...
Dim shape_index() As Variant

How to store Global Array

In my Workbook i have an Array which stores machines. With a button i am able to add some machines to the array.
The final array is used in three other buttons, each button is on a different worksheet. My question now is, how do i store the array global with its changing value?
this is my code for adding some value to the array:
Private Sub Add_Machine_Click()
Dim ws As Worksheet
Dim lastrow As Long
Dim Machine() As Variant
Dim DataRange As Range
Set ws = Worksheets("MachineTemplate")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set DataRange = ws.Range("A1:A" & lastrow)
Set Cell = DataRange.Find(What:=ComboBox1.Value, LookIn:=xlFormulas, lookat:=xlWhole)
If Cell Is Nothing Then
ws.Range("A" & lastrow + 1) = ComboBox1.Value
End If
ReDim Machine(DataRange.Cells.Count)
For Each Cell In DataRange.Cells
Machine(x) = Cell.Value
x = x + 1
Next Cell
End Sub
Right now i use the same code for the other three buttons. is there a way i can store this code as global?
I allready tried it in the WorkbookSheet like this:
Option Explicit
Public Machine() As Variant
Public ws As Worksheet
Public lastrow As Long
Public DataRange As Range
ws = Worksheets("MachineTemplate")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set DataRange = ws.Range("A1:A" & lastrow)
ReDim Machine(DataRange.Cells.Count)
x = 0
For Each Cell In DataRange.Cells
Machine(x) = Cell.Value
x = x + 1
Next Cell
But i know that this is totally wrong.
You do not need a Global Array for this. Since you are using Redim without Preserve, then it means it is getting initialzed everytime from the range DataRange
Also to create the array, you do not need to loop trough it everytime. You can directly create a 2D array in one line
Dim Machine as Variant
Machine = DataRange.Value
You may also want to see VBA Arrays And Worksheet Ranges
I usually avoid using Global variables. They get reset very easily during runtime if an error happens.

Resources