Dynamically dimension/populate a 2D array - arrays

I have an interesting problem. I need to fill in a 2D array with data, but I don't know how many data points there are until after the array is populated.
Dim finalArray(0 to 500000, 0 to 3)
R=0
For Each index in someDictionary
If Not someDictionary.item(index)(1) = 0
finalArray(R,0) = someDictionary.item(index)(1)
finalArray(R,1) = someDictionary.item(index)(2)
finalArray(R,2) = someDictionary.item(index)(3)
R = R + 1
End If
Next index
The issue is that I don't know how many items will be in the dictionary, nor how many will be nonzero. The only way I know is after I run the loop and have a count R.
Currently I'm printing the entire 500k row array to Excel, which is usually 100-400k rows of data with the rest blank. This is ungainly, and I would like to re-dimension the array to be the correct size. I can't use ReDim because I can't delete the data, and I can't use ReDim Preserve because it's 2-dimensional and I need to reduce the rows, not columns.

How about this?
Sub Sample()
Dim finalArray()
Dim R As Long
For Each Index In someDictionary
If Not someDictionary.Item(Index)(1) = 0 Then R = R + 1
Next Index
ReDim finalArray(0 To R, 0 To 3)
R = 0
For Each Index In someDictionary
If Not someDictionary.Item(Index)(1) = 0 Then
finalArray(R, 0) = someDictionary.Item(Index)(1)
finalArray(R, 1) = someDictionary.Item(Index)(2)
finalArray(R, 2) = someDictionary.Item(Index)(3)
R = R + 1
End If
Next Index
End Sub

You have a few options
Redim the array as needed rather then create up front (which I think is better than looping through the array twice :)). I have added this given your comment to tigeravatar
Transpose the array to redim the first dimension
Ignore the redundant data as per tigeravatar
Option 1
note I have flipped the data to make the point around testing for ReDim as you go rather than define an array size up front - it could well argue this changes the nature of the question but I thought the technique worth pointing out. Option2 shows how to transpose the array regardless
Sub SloaneDog()
Dim finalArray()
Dim R As Long
Dim lngCnt As Long
Dim lngCnt2 As Long
lngCnt = 100
ReDim finalArray(1 To 3, 1 To lngCnt)
somedictionary = Range("A1:C3001")
For lngCnt2 = 1 To UBound(somedictionary, 1)
finalArray(1, lngCnt2) = "data " & lngCnt2
If lngCnt2 Mod lngCnt = 0 Then ReDim Preserve finalArray(1 To 3, 1 To lngCnt2 + lngCnt)
Next
End Sub
Option 2
Sub EddieBetts()
Dim X()
Dim Y()
Dim LngCnt As Long
ReDim X(1 To 1000, 1 To 3)
Debug.Print UBound(X, 1)
LngCnt = 100
Y = Application.Transpose(X)
ReDim Preserve Y(1 To UBound(Y, 1), 1 To LngCnt)
X = Application.Transpose(Y)
Debug.Print UBound(X, 1)
End Sub

Related

VBA - How to take a single column as input array then output the array removing all odd numbers

I have a very basic question, but would love to know how to do this. I want to write a function in VBA where I can highlight a column as an input, and then spit out the result somewhere else.
Thanks in advance :)
e.g. column A
--------
10
8
5
6
1
3
2
becomes:
column A
--------
10
8
6
2
I just did it from column a to b, but you probably want range as the current selection and a different output column.
Option Explicit
Sub filterlist()
Dim rng As Range
Set rng = Range("a1:a5")
Dim celluse As Range
Dim arr As Variant
For Each celluse In rng
If celluse.Value Mod 2 = 0 Then
If IsEmpty(arr) Then
arr = Array(celluse.Value)
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = celluse.Value
End If
End If
Next celluse
Dim i As Long
For i = 0 To UBound(arr)
Range("b" & i + 1) = arr(i)
Next i
End Sub
This code should do the trick.
You can enter as an array-formula directly to a sheet: {=RemoveOdds(A1:A7)} or as part of another procedure:
Sub Test()
RemoveOdds Selection
End Sub
Public Function RemoveOdds(Target As Range) As Variant
Dim vFinal() As Variant
Dim rCell As Range
Dim x As Long
ReDim vFinal(1 To Target.Cells.Count)
x = 1
For Each rCell In Target
If rCell Mod 2 = 0 Then
vFinal(x) = rCell.Value
x = x + 1
End If
Next rCell
'So missing values do not show up as 0 at bottom of array.
' Do While x <= Target.Cells.Count
' vFinal(x) = ""
' x = x + 1
' Loop
ReDim Preserve vFinal(1 To x - 1)
'RemoveOdds = vFinal 'Basic array - will place values horizontally on sheet.
RemoveOdds = Application.Transpose(vFinal) 'Will place values vertically on sheet.
End Function

Loop to replicate values into an array

I’m in a situation where I need to reproduce something in VBA and a bit stuck given my lack of understanding of object oriented language and VBA in general.
Problem:
I need to produce an array or vector based on a 2 column table.
The first range (column) contains unit counts.
The second range (column) contains numeric values.
I need to replicate the value based on the number of units.
For example,
if the first row contains 3 units with a value of $100
I need the array to contain $100, $100, $100.
This will need to be looped thru each row containing units.
So if row 2 contains 2 units with a value of $50
I need to complete array to be $100, $100, $100, $50, $50, and so on.
I understand this situation will require ReDim the array based on the total values. My struggle is I’ve been unable to figure out the nested for loops.
I get how to replicate the value based on the number of “units” like the below...
ReDim arr(0 To x - 1)
For i = 0 To x - 1
arr(i) = rng.Offset(0, 1).Value
Next
What is the best way to loop thru each row and replicate the values for each row in the range based on the unit count?
If anyone is familiar with R, I'm essentially looking for something that achieves the rep() function (e.g., rep(df$b, df$a)) and return the values in a single array.
Any help is greatly appreciated. Thanks
Or a one liner which uses the REPT function as you would have used in r :)
This assumes your data is in A1:B10 - the length can be made variable
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
An an example, to dump the new to array to C1
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
[c1].Resize(UBound(s), 1) = Application.Transpose(s)
When you say Row contains 3 units, do you mean the cell has value 3 or 3 Units? If it is 3 then you may not have to Redim the array in the loop. Simply find the sum of values in Col A which has units and Redim it in one go as shown below.
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String
Dim n As Long, i As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
n = Application.WorksheetFunction.Sum(.Columns(1))
ReDim Ar(t To n)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
For j = 1 To .Range("A" & i).Value
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = LBound(Ar) To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
And if the cell has 3 Units then you will have to store the values of Col A in an array, do a replace on Unit/Units, find the sum and finally use the above code. Here is an example
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String, tmpAr As Variant
Dim n As Long, i As Long, j As Long, k As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
tmpAr = .Range("A1:A" & lRow).Value
For i = LBound(tmpAr) To UBound(tmpAr)
tmpAr(i, 1) = Replace(tmpAr(i, 1), "Units", "")
tmpAr(i, 1) = Trim(Replace(tmpAr(i, 1), "Unit", ""))
n = n + Val(tmpAr(i, 1))
Next i
ReDim Ar(t To n)
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
k = Val(Trim(Replace(Replace(.Range("A" & i).Value, "Units", ""), "Unit", "")))
For j = 1 To k
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = 1 To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
if your data is already in an array then ReDim'ing will delete it's contents. You can ReDim Preserve but it's an expensive operation, better to create a new array to put the results into.
I have assumed the data is contained within a Named Range called "Data" with Units being the first column and Values being the second column.
if your data changes regularly you can create a dynamic range using the OFFSET function i.e. =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),2) assuming your data starts in cell A1 and there is no header row.
Sub ProcessData()
Dim DataArr() As Variant
Dim QtyColArr() As Variant
Dim ResultArr() As Variant
Dim TotalQty As Long
Dim i As Long, j As Long, k As Long
'store data into array
DataArr = Range("Data") 'assume data stored in named range called "Data"
'store Qty col into 1D array
QtyColArr = Range("Data").Resize(, 1)
'sum all qty vals
TotalQty = Application.Sum(QtyColArr)
're-size ResultsArray
ReDim ResultArr(1 To TotalQty)
'Initialize ResultsArr counter
k = LBound(ResultArr)
'loop DataArr
For i = LBound(DataArr) To UBound(DataArr)
'loop qty for current row
For j = 1 To DataArr(i, 1)
'copy value
ResultArr(k) = DataArr(i, 2)
'iterate ResultsArr counter
k = k + 1
Next j
Next i
'output to intermediate window
Debug.Print "{" & Join(ResultArr) & "}"
End Sub

Excel VBA Listrow to Array

I have the below snippit for excel 2013 VBA
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
ReDim Preserve testArr(1 To FNum, 1 To 23)
testArr(FNum) = r
End If
Next r
My goal is to get all the visible rows from a filtered table into an array.
The table can be any number of rows, but always 23 columns.
I found that the height will be zero if it is hidden. But for the life of me, I cannot figure out how to get the entire row into the array.
r = listrow
rr = listrows
YES, I know a looping redim sucks.
SpecialCells(xlCellTypeVisible)
doesnt work either because it stops at the first hidden row/column.
I may just dump the entire table into the array and then filter the array. I havent figured out how to pull the active filter from the table to apply it, but I havent looked deeply into that yet. Thats what I will be doing now, because I am stuck for the other way.
Any and all advice is welcome.
DM
To avoid REDIM or double loops you can use something like Application.WorksheetFunction.Subtotal(3, Range("A2:A500000")) to quickly count the number of visible rows.
See this question
I define my Target range using .SpecialCells(xlCellTypeVisible). Target.Cells.Count / Target.Columns.Count will give you the row count. Finally I iterate over the cells in the Target range incrementing my counters based off of the Target.Columns.Count.
Public Sub FilteredArray()
Dim Data As Variant, r As Range, Target As Range
Dim rowCount As Long, x As Long, y As Long
Set Target = WorkSheets("Sheet1").ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible)
If Not Target Is Nothing Then
rowCount = Target.Cells.Count / Target.Columns.Count
ReDim Data(1 To rowCount, 1 To Target.Columns.Count)
x = 1
For Each r In Target
y = y + 1
If y > Target.Columns.Count Then
x = x + 1
y = 1
End If
Data(x, y) = r.Value
Next
End If
End Sub
The code below will create an array for all the rows and store each of these into another array that will store all info in sheet:
Function RowsToArray()
Dim lastRow: lastRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol: lastCol = ActiveWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim newArr()
ReDim newArr(lastRow)
For r = 0 To lastRow - 1
Dim rowarr()
ReDim rowarr(lastCol)
For c = 0 To lastCol - 1
rowarr(c) = Cells(r + 1, c + 1).Value
Next c
newArr(r) = rowarr
Next r
End Function
Can you loop over the cells in rr rather than the rows? If so, as #SJR says, you can only Redim Preserve the final dimension, so we're going to have to switch your dimensions. You can then use r.EntireRow.Hidden to check if we're in a visible row and increase the bound of your array by one if we are.
The following assumes that your data starts in column A:
For Each r In rr
If Not r.EntireRow.Hidden Then
If r.Column = 1 Then
If UBound(testArr, 2) = 0 Then
ReDim testArr(1 To 23, 1 To 1)
Else
ReDim Preserve testArr(1 To 23, 1 To UBound(testArr, 2) + 1)
End If
End If
testArr(r.Column, UBound(testArr, 2)) = r
End If
Next r
Edit:
Alternatively, you can keep using ListRows, but loop through twice, once to set the bounds of your array, and once to fill the array (which will have its own internal loop to run through the row...):
For Each r In rr
If Not r.Range.Height = 0 Then
Fnum = Fnum + 1
ReDim testArr(1 To Fnum, 1 To 3)
End If
Next r
Fnum = 0
For Each r In rr
If Not r.Range.RowHeight = 0 Then
Fnum = Fnum + 1
dumarray = r.Range
For i = 1 To 3
testArr(Fnum, i) = dumarray(1, i)
Next i
End If
Next r
Thanks all, a combo of answers led me to: (not very elegant, but quick)
For Each r In rr
If Not r.Range.Height = 0 Then
TNum = TNum + 1
End If
Next r
ReDim testArr(TNum, 23)
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
For i = 1 To 23
testArr(FNum, i) = r.Range.Cells(, i)
Next i
End If
Next r

Get values from union of non-contiguous ranges into array with VBA with a simple command (no loops)

I have the following (on the surface of it, simple) task:
Copy the values from a number of columns on a spreadsheet into a 2D array using VBA.
To make life more interesting, the columns are not adjacent, but they are all of the same length. Obviously one could do this by looping over every element in turn, but that seems very inelegant. I am hoping there is a more compact solution - but I struggle to find it.
Here are some attempts of what I would consider "a simple approach" - for simplicity, I am putting the range as A1:A5, D1:D5 - a total of 10 cells in two ranges.
Private Sub testIt()
Dim r1, r2, ra, rd, rad
Dim valString, valUnion, valBlock
Set r1 = Range("A1:A5")
Set r2 = Range("D1:D5")
valString = Range("A1:A5,D1:D5").Value
valUnion = Union(r1, r2).Value
valBlock = Range("A1:D5").Value
End Sub
When I look at each of these variables, the first two have dimension (1 To 5, 1 To 1) while the last one has (1 To 5, 1 To 4). I was expecting to get (1 To 5, 1 To 2) for the first two, but that was not the case.
I would be happy if I could loop over the data one column at the time, and assign all the values in one column to one column in the array - but I could not figure out how to do that either. Something like
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
vals( , ci) = Range(c & "1:" & c & "5").Value
ci = ci + 1
Next c
But that's not the right syntax. The result I want to get would be achieved with
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
For ri = 1 To 5
vals(ri , ci) = Range(c & "1").offset(ri-1,0).Value
Next ri
ci = ci + 1
Next c
But that's pretty ugly. So here is my question:
Is it possible to get the values of a "composite range" (multiple non-contiguous blocks) into an array - either all at once, or a columns at a time? If so, how do I do it?
For extra bonus points - can anyone explain why the arrays returned in testIt() are dimensioned Base 1, whereas my VBA is set to Option Base 0? In other words - why are they not (0 To 4, 0 To 0)? Is this just one more inconsistency on the part of Microsoft?
Provided each area in rng has the same number of rows then this should work.
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1 'EDIT: added missing line...
Next c
Next col
Next ar
ToArray = arr
End Function
Usage:
Dim arr
arr = ToArray(Activesheet.Range("A1:A5,D1:D5"))
Debug.Print UBound(arr,1), UBound(arr,2)
As for why array from rng.Value are 1-based instead of zero-based, I'd guess it's because that maps more readily to actual row/column numbers on the worksheet than if it were zero-based. The Option Base x setting is ignored
It is possible to accomplish what you want if you're willing to add a hidden worksheet. I used Excel 2010 and created two worksheets (Sheet1 / Sheet2) to test my findings. Below is the code:
Private Sub TestIt()
' Src = source
' Dst = destination
' WS = worksheet
Dim Data As Variant
Dim SrcWS As Excel.Worksheet
Dim DstWS As Excel.Worksheet
' Get a reference to the worksheet containing the
' source data
Set SrcWS = ThisWorkbook.Worksheets("Sheet1")
' Get a reference to a hidden worksheet.
Set DstWS = ThisWorkbook.Worksheets("Sheet2")
' Delete any data found on the hidden worksheet
DstWS.UsedRange.Columns.EntireColumn.Delete
' Copy the non-contiguous range into the hidden
' worksheet.
SrcWS.Range("A1:A5,D1:D5").Copy DstWS.Range("A1")
' Now all of the data can be stored in a variable
' as a 2D array because it will be contiguous on
' the hidden worksheet.
Data = DstWS.UsedRange.Value
End Sub
Tim,
Thanks for your sample code. I had some problems with it and had to rewrite some portions of it. It wasn't counting through the rows and columns correctly. I have test this and it is working 100%
Function ToArray(rng As Range) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
Dim lastrow As Integer
Dim saverow() As Integer
Dim lastcolumn As Integer
Dim templastcolumn As Integer
For i = 1 To rng.Areas.Count
templastcolumn = (rng.Areas(i).Column + rng.Areas(i).CountLarge) - 1
If lastrow <> rng.Areas(i).Row Then
nr = nr + rng.Areas(i).Rows.Count
lastrow = rng.Areas(i).Row
End If
If lastcolumn < templastcolumn Then lastcolumn = templastcolumn
Next i
ReDim arr(1 To nr, 1 To lastcolumn)
ReDim saverow(1 To lastrow)
cnum = 0
rnum = 0
lastrow = 0
For Each ar In rng.Areas
If lastrow <> ar.Row Then
lastrow = ar.Row
cnum = 0
End If
For Each col In ar.Columns
cnum = cnum + 1
For Each c In col.Cells
If saverow(c.Row) = 0 Then
rnum = rnum + 1
saverow(c.Row) = rnum
End If
arr(saverow(c.Row), cnum) = c.value
Next c
Next col
Next ar
ToArray = arr
End Function
Sub TestCopyArray()
Dim arr As Variant
arr = ToArray(ThisWorkbook.Sheets("MSS").Range("B1:D2,G1:J2,B4:D4,B6:D6"))
ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

ReDim Preserve to a multi-dimensional array in VB6

I'm using VB6 and I need to do a ReDim Preserve to a Multi-Dimensional Array:
Dim n, m As Integer
n = 1
m = 0
Dim arrCity() As String
ReDim arrCity(n, m)
n = n + 1
m = m + 1
ReDim Preserve arrCity(n, m)
Whenever I do it as I have written it, I get the following error:
runtime error 9: subscript out of range
Because I can only change the last array dimension, well in my task I have to change the whole array (2 dimensions in my example) !
Is there any workaround or another solution for this?
As you correctly point out, one can ReDim Preserve only the last dimension of an array (ReDim Statement on MSDN):
If you use the Preserve keyword, you can resize only the last array
dimension and you can't change the number of dimensions at all. For
example, if your array has only one dimension, you can resize that
dimension because it is the last and only dimension. However, if your
array has two or more dimensions, you can change the size of only the
last dimension and still preserve the contents of the array
Hence, the first issue to decide is whether 2-dimensional array is the best data structure for the job. Maybe, 1-dimensional array is a better fit as you need to do ReDim Preserve?
Another way is to use jagged array as per Pieter Geerkens's suggestion. There is no direct support for jagged arrays in VB6. One way to code "array of arrays" in VB6 is to declare an array of Variant and make each element an array of desired type (String in your case). Demo code is below.
Yet another option is to implement Preserve part on your own. For that you'll need to create a copy of data to be preserved and then fill redimensioned array with it.
Option Explicit
Public Sub TestMatrixResize()
Const MAX_D1 As Long = 2
Const MAX_D2 As Long = 3
Dim arr() As Variant
InitMatrix arr, MAX_D1, MAX_D2
PrintMatrix "Original array:", arr
ResizeMatrix arr, MAX_D1 + 1, MAX_D2 + 1
PrintMatrix "Resized array:", arr
End Sub
Private Sub InitMatrix(a() As Variant, n As Long, m As Long)
Dim i As Long, j As Long
Dim StringArray() As String
ReDim a(n)
For i = 0 To n
ReDim StringArray(m)
For j = 0 To m
StringArray(j) = i * (m + 1) + j
Next j
a(i) = StringArray
Next i
End Sub
Private Sub PrintMatrix(heading As String, a() As Variant)
Dim i As Long, j As Long
Dim s As String
Debug.Print heading
For i = 0 To UBound(a)
s = ""
For j = 0 To UBound(a(i))
s = s & a(i)(j) & "; "
Next j
Debug.Print s
Next i
End Sub
Private Sub ResizeMatrix(a() As Variant, n As Long, m As Long)
Dim i As Long
Dim StringArray() As String
ReDim Preserve a(n)
For i = 0 To n - 1
StringArray = a(i)
ReDim Preserve StringArray(m)
a(i) = StringArray
Next i
ReDim StringArray(m)
a(n) = StringArray
End Sub
Since VB6 is very similar to VBA, I think I might have a solution which does not require this much code to ReDim a 2-dimensional array - using Transpose, if you are working in Excel.
The solution (Excel VBA):
Dim n, m As Integer
n = 2
m = 1
Dim arrCity() As Variant
ReDim arrCity(1 To n, 1 To m)
m = m + 1
ReDim Preserve arrCity(1 To n, 1 To m)
arrCity = Application.Transpose(arrCity)
n = n + 1
ReDim Preserve arrCity(1 To m, 1 To n)
arrCity = Application.Transpose(arrCity)
What is different from OP's question: the lower bound of arrCity array is not 0, but 1. This is in order to let Application.Transpose do it's job.
Note that Transpose is a method of the Excel Application object (which in actuality is a shortcut to Application.WorksheetFunction.Transpose). And in VBA, one must take care when using Transpose as it has two significant limitations: If the array has more than 65536 elements, it will fail. If ANY element's length exceed 256 characters, it will fail. If neither of these is an issue, then Transpose will nicely convert the rank of an array form 1D to 2D or vice-versa.
Unfortunately there is nothing like 'Transpose' build into VB6.
In regards to this:
"in my task I have to change the whole array (2 dimensions"
Just use a "jagged" array (ie an array of arrays of values). Then you can change the dimensions as you wish. You can have a 1-D array of variants, and the variants can contain arrays.
A bit more work perhaps, but a solution.
I haven't tested every single one of these answers but you don't need to use complicated functions to accomplish this. It's so much easier than that! My code below will work in any office VBA application (Word, Access, Excel, Outlook, etc.) and is very simple. Hope this helps:
''Dimension 2 Arrays
Dim InnerArray(1 To 3) As Variant ''The inner is for storing each column value of the current row
Dim OuterArray() As Variant ''The outer is for storing each row in
Dim i As Byte
i = 1
Do While i <= 5
''Enlarging our outer array to store a/another row
ReDim Preserve OuterArray(1 To i)
''Loading the current row column data in
InnerArray(1) = "My First Column in Row " & i
InnerArray(2) = "My Second Column in Row " & i
InnerArray(3) = "My Third Column in Row " & i
''Loading the entire row into our array
OuterArray(i) = InnerArray
i = i + 1
Loop
''Example print out of the array to the Intermediate Window
Debug.Print OuterArray(1)(1)
Debug.Print OuterArray(1)(2)
Debug.Print OuterArray(2)(1)
Debug.Print OuterArray(2)(2)
I know this is a bit old but I think there might be a much simpler solution that requires no additional coding:
Instead of transposing, redimming and transposing again, and if we talk about a two dimensional array, why not just store the values transposed to begin with. In that case redim preserve actually increases the right (second) dimension from the start. Or in other words, to visualise it, why not store in two rows instead of two columns if only the nr of columns can be increased with redim preserve.
the indexes would than be 00-01, 01-11, 02-12, 03-13, 04-14, 05-15 ... 0 25-1 25 etcetera instead of 00-01, 10-11, 20-21, 30-31, 40-41 etcetera.
As long as there is only one dimension that needs to be redimmed-preserved the approach would still work: just put that dimension last.
As only the second (or last) dimension can be preserved while redimming, one could maybe argue that this is how arrays are supposed to be used to begin with.
I have not seen this solution anywhere so maybe I'm overlooking something?
(Posted earlier on similar question regarding two dimensions, extended answer here for more dimensions)
You can use a user defined type containing an array of strings which will be the inner array. Then you can use an array of this user defined type as your outer array.
Have a look at the following test project:
'1 form with:
' command button: name=Command1
' command button: name=Command2
Option Explicit
Private Type MyArray
strInner() As String
End Type
Private mudtOuter() As MyArray
Private Sub Command1_Click()
'change the dimensens of the outer array, and fill the extra elements with "1"
Dim intOuter As Integer
Dim intInner As Integer
Dim intOldOuter As Integer
intOldOuter = UBound(mudtOuter)
ReDim Preserve mudtOuter(intOldOuter + 2) As MyArray
For intOuter = intOldOuter + 1 To UBound(mudtOuter)
ReDim mudtOuter(intOuter).strInner(intOuter) As String
For intInner = 0 To UBound(mudtOuter(intOuter).strInner)
mudtOuter(intOuter).strInner(intInner) = "1"
Next intInner
Next intOuter
End Sub
Private Sub Command2_Click()
'change the dimensions of the middle inner array, and fill the extra elements with "2"
Dim intOuter As Integer
Dim intInner As Integer
Dim intOldInner As Integer
intOuter = UBound(mudtOuter) / 2
intOldInner = UBound(mudtOuter(intOuter).strInner)
ReDim Preserve mudtOuter(intOuter).strInner(intOldInner + 5) As String
For intInner = intOldInner + 1 To UBound(mudtOuter(intOuter).strInner)
mudtOuter(intOuter).strInner(intInner) = "2"
Next intInner
End Sub
Private Sub Form_Click()
'clear the form and print the outer,inner arrays
Dim intOuter As Integer
Dim intInner As Integer
Cls
For intOuter = 0 To UBound(mudtOuter)
For intInner = 0 To UBound(mudtOuter(intOuter).strInner)
Print CStr(intOuter) & "," & CStr(intInner) & " = " & mudtOuter(intOuter).strInner(intInner)
Next intInner
Print "" 'add an empty line between the outer array elements
Next intOuter
End Sub
Private Sub Form_Load()
'init the arrays
Dim intOuter As Integer
Dim intInner As Integer
ReDim mudtOuter(5) As MyArray
For intOuter = 0 To UBound(mudtOuter)
ReDim mudtOuter(intOuter).strInner(intOuter) As String
For intInner = 0 To UBound(mudtOuter(intOuter).strInner)
mudtOuter(intOuter).strInner(intInner) = CStr((intOuter + 1) * (intInner + 1))
Next intInner
Next intOuter
WindowState = vbMaximized
End Sub
Run the project, and click on the form to display the contents of the arrays.
Click on Command1 to enlarge the outer array, and click on the form again to show the results.
Click on Command2 to enlarge an inner array, and click on the form again to show the results.
Be careful though: when you redim the outer array, you also have to redim the inner arrays for all the new elements of the outer array
I stumbled across this question while hitting this road block myself. I ended up writing a piece of code real quick to handle this ReDim Preserve on a new sized array (first or last dimension). Maybe it will help others who face the same issue.
So for the usage, lets say you have your array originally set as MyArray(3,5), and you want to make the dimensions (first too!) larger, lets just say to MyArray(10,20). You would be used to doing something like this right?
ReDim Preserve MyArray(10,20) '<-- Returns Error
But unfortunately that returns an error because you tried to change the size of the first dimension. So with my function, you would just do something like this instead:
MyArray = ReDimPreserve(MyArray,10,20)
Now the array is larger, and the data is preserved. Your ReDim Preserve for a Multi-Dimension array is complete. :)
And last but not least, the miraculous function: ReDimPreserve()
'redim preserve both dimensions for a multidimension array *ONLY
Public Function ReDimPreserve(aArrayToPreserve,nNewFirstUBound,nNewLastUBound)
ReDimPreserve = False
'check if its in array first
If IsArray(aArrayToPreserve) Then
'create new array
ReDim aPreservedArray(nNewFirstUBound,nNewLastUBound)
'get old lBound/uBound
nOldFirstUBound = uBound(aArrayToPreserve,1)
nOldLastUBound = uBound(aArrayToPreserve,2)
'loop through first
For nFirst = lBound(aArrayToPreserve,1) to nNewFirstUBound
For nLast = lBound(aArrayToPreserve,2) to nNewLastUBound
'if its in range, then append to new array the same way
If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
aPreservedArray(nFirst,nLast) = aArrayToPreserve(nFirst,nLast)
End If
Next
Next
'return the array redimmed
If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
End If
End Function
I wrote this in like 20 minutes, so there's no guarantees. But if you would like to use or extend it, feel free. I would've thought that someone would've had some code like this up here already, well apparently not. So here ya go fellow gearheads.
This is more compact and respect the intial first position in array and just use the inital bound to add old value.
Public Sub ReDimPreserve(ByRef arr, ByVal size1 As Long, ByVal size2 As Long)
Dim arr2 As Variant
Dim x As Long, y As Long
'Check if it's an array first
If Not IsArray(arr) Then Exit Sub
'create new array with initial start
ReDim arr2(LBound(arr, 1) To size1, LBound(arr, 2) To size2)
'loop through first
For x = LBound(arr, 1) To UBound(arr, 1)
For y = LBound(arr, 2) To UBound(arr, 2)
'if its in range, then append to new array the same way
arr2(x, y) = arr(x, y)
Next
Next
'return byref
arr = arr2
End Sub
I call this sub with this line to resize the first dimension
ReDimPreserve arr2, UBound(arr2, 1) + 1, UBound(arr2, 2)
You can add an other test to verify if the initial size is not upper than new array. In my case it's not necessary
Easiest way to do this in VBA is to create a function that takes in an array, your new amount of rows, and new amount of columns.
Run the below function to copy in all of the old data back to the array after it has been resized.
function dynamic_preserve(array1, num_rows, num_cols)
dim array2 as variant
array2 = array1
reDim array1(1 to num_rows, 1 to num_cols)
for i = lbound(array2, 1) to ubound(array2, 2)
for j = lbound(array2,2) to ubound(array2,2)
array1(i,j) = array2(i,j)
next j
next i
dynamic_preserve = array1
end function
Function Redim2d(ByRef Mtx As Variant, ByVal QtyColumnToAdd As Integer)
ReDim Preserve Mtx(LBound(Mtx, 1) To UBound(Mtx, 1), LBound(Mtx, 2) To UBound(Mtx, 2) + QtyColumnToAdd)
End Function
'Main Code
sub Main ()
Call Redim2d(MtxR8Strat, 1) 'Add one column
end sub
'OR
sub main2()
QtyColumnToAdd = 1 'Add one column
ReDim Preserve Mtx(LBound(Mtx, 1) To UBound(Mtx, 1), LBound(Mtx, 2) To UBound(Mtx, 2) + QtyColumnToAdd)
end sub
If you not want include other function like 'ReDimPreserve' could use temporal matrix for resizing. On based to your code:
Dim n As Integer, m As Integer, i as Long, j as Long
Dim arrTemporal() as Variant
n = 1
m = 0
Dim arrCity() As String
ReDim arrCity(n, m)
n = n + 1
m = m + 1
'VBA automatically adapts the size of the receiving matrix.
arrTemporal = arrCity
ReDim arrCity(n, m)
'Loop for assign values to arrCity
For i = 1 To UBound(arrTemporal , 1)
For j = 1 To UBound(arrTemporal , 2)
arrCity(i, j) = arrTemporal (i, j)
Next
Next
If you not declare of type VBA assume that is Variant.
Dim n as Integer, m As Integer

Resources