In Excel, I have a list of items with their weight. I've made a function in VBA which picks random items out of the list as long as the total weight is under 10.
Before this function I made an array of only zero's which should belong each to an item. When the random function picks an item, this place in the array should change into an one, but this part of the function doesn't work.
Can anyone help me to solve this problem/repair the function?
This is my code:
Sub Test()
Dim weight As Single, totWeight As Single
Dim finish As Boolean
Dim r As Integer
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66) As String, i As Integer
For r = 1 To 66
Arr(r) = 0
Next r
Do Until finish = True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + Cells(r, 2)
'Change the position of the item in the array into a 1
'But it doesn't work
--> Arr(r) = 1
Else
'Do as long as the weight is under 10
finish = True
End If
Loop
'It only prints zero's
PrintArray Arr, ActiveWorkbook.Worksheets("Sheet1").[F1]
End Sub
(btw, this is the print function:
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1)) = Data
End Sub)
I debuged your code, and it seems that problem is in your print function. Try this one
Sub PrintArray(Data As Variant, Cl As Range)
Dim i As Integer
For i = LBound(Data) To UBound(Data)
Cl.Cells(i, 1).Value = Data(i)
Next i
End Sub
If you are interested why your solution didnt work, i think its because you tried to assign array into value. So always when need to copy array, do it item by item...
The reason it seemed like you were not putting ones into the array is because the array was oriented backwards to the way you were dumping the array elements' values back into the worksheet. Essentially, you were filling all 66 cells with the value from the first element (e.g. arr(1)). If you did this enough times, sooner or later the random r var would come out as 1 and the first element of the array would receive a 1. In this case, all of the cells would be ones.
With your single dimension array, you can use the Excel Application object's TRANSPOSE function to flip your array from what is essentially 1 row × 66 columns into 66 rows × 1 column.
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data)) = Application.Transpose(Data)
End Sub
That is a bit of a bandaid fix and the Application.Transpose has some limits (somewhere around an unsigned int - 1).
If you are creating an array for the end purpose of populating an range of cells on a worksheet, start with a 2 dimensioned array and stick with it. Keep the rank of the array correct and you won't have any problems dumping the values back into the worksheet.
Sub Test()
Dim weight As Single, totWeight As Single
Dim r As Long
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66, 1 To 1) As String, i As Integer
For r = LBound(Arr, 1) To UBound(Arr, 1)
Arr(r, 1) = 0
Next r
With ActiveWorkbook.Worksheets("Sheet1")
Do While True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + .Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + .Cells(r, 2)
'Change the position of the item in the array into a 1
Arr(r, 1) = 1 '<~~
Else
'just exit - no need to set a boolean
Exit Do
End If
Loop
PrintArray Arr, .Range("F2")
End With
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
This won't make much difference with 66 rows but with respect to Luboš Suk and his excellent answer, looping through 100K cells to stuff arrayed values back into a worksheet is pretty slow by array standards and we use arrays on reasonably large data blocks because they are faster. Dumping the values back en masse is almost instantaneous.
Related
Code worked fine with fixed dim array but when I have added line to Redim to make Results array dynamic the code will not allow results to be added to array coming up with "Type Mismatch" error. I am sure a simple fix, have played around but can I see it..
GP (Gross Profit) Range of values picked up form single column range GPRange and Price Change its from single row PriceRange).
Option Explicit
Sub CalcVolTable()
'Macro to produce table that shows relationship between price and volume change
Dim PriceChangeAr As Variant, GPAr As Variant
Dim GPList, GPNum, PriceIndex, PriceChNum As Integer
Dim GP As Double
With ThisWorkbook
' Read all PriceChanges into a 1-dimensional array
PriceChangeAr = (.Worksheets("Results").Range("PriceRange").Value2)
' Read all GP range into a 1-dimensional array
GPAr = Application.Transpose(.Worksheets("Results").Range("GPRange").Value)
'Clear Previous Results
Range("VolTable").ClearContents
Range("Output").Select
'Set up Results Array
'Dim VolResultsAr(1 To 8, 1 To 7) As Variant - this worked before I tried to make array dynamic
Dim VolResultsAr As Variant
PriceChNum = UBound(PriceChangeAr, 2)
GPNum = UBound(GPAr)
ReDim VolResults(1 To GPNum, 1 To PriceChNum) As Variant
For GPList = LBound(GPAr) To UBound(GPAr)
GP = GPAr(GPList)
'Set Cost per Unit value to get right GP in calc
Range("CostPerUnit").Value = 100 * (1 - GP)
' Now loop through each pricechange
For PriceIndex = LBound(PriceChangeAr, 2) To UBound(PriceChangeAr, 2)
'Reset Price and Vol adjt cell to zero
Range("ChPrice") = 0
Range("Chvol") = 0
'enter new Price Cahnge value
Range("ChPrice").Value = PriceChangeAr(1, PriceIndex)
'Use goal seek to calc vol chage req'd to bring GP back to same preset value
Range("GP").GoalSeek Goal:=GP, ChangingCell:=Range("ChVol")
'Writes result to cells in table in spreadsheet
Range("Output").Offset(GPList - 1, PriceIndex - 1).Value = Range("ChVol").Value
'CODE FALLING DOWN HERE - TRYING TO WRITE EACH RESULT INTO ARRAY
VolResultsAr(GPList, PriceIndex) = Range("ChVol").Value
Next PriceIndex
Next GPList
Range("Output2").Resize(UBound(VolResultsAr, 1), UBound(VolResultsAr, 2)) = VolResultsAr
Range("Output").Select
End With
MsgBox "done!"
End Sub
Assuming the arrays need to match you need to ReDim VolResultsAr
ReDim VolResults(1 To GPNum, 1 To PriceChNum) As Variant
ReDim VolResultsAr(1 To GPNum, 1 To PriceChNum) As Variant
And for lines like:
Dim GPList, GPNum, PriceIndex, PriceChNum As Integer .
Only PriceChNum is Integer, the others are variant. Is that what you intended? And Integer should be replaced with Long to avoid potential overflow
I need a function to extract 2 dimensions from a multidimesion array. which 2 dimensions to extract depending on the choise of the user. and the index in the discarded dimensions where those 2 dimensions are picked also depending on the user.
For example, i have a 3 dimension array v(1 to 100, 1 to 20, 1 to 10). i would like to extrat dimension 1 and dimension 3 from v. and the index in the discared dimension 2 is 11.
sub extract
dim i1 as integer 'for loop through dimension 1
dim i2 as integer 'for loop through dimension 3
dim d1 as integer 'index in dimension 2
d1=11
redim vn(1 to ubound(v,1),1 to ubound (v,3))
for i1 = 1 to ubound(v,1)
for i2= 1 to ubound(v,3)
vn(i1,i2)=v(i1,d1,i2)
next i2
next i1
end sub
I can extract dimensions from array, if i know which dimensions i need and the index (d1) in the discarded dimensions. however, i need to leave that to the users to decide. what i want is a function like that:
function extract(i1 as integer, i2 as intger, paramarray ov()) as variant
=extract(the_first_dimension_to_keep,the_second_dimension_to_keep,[index_in_the_first_discard_dimension,index_in_the_second_discard_dimension,...])
Keeping in mind that the origional array can have more than 3 dimensions, so list all the possibility in the code is not possible.
Any solution?
The quickest way would be to read the array with a pointer and increment the pointer value by an algorithmic value based on the number of dimensions and number of elements in each. This site has an excellent tutorial on managing pointers to arrays: http://bytecomb.com/vba-internals-getting-pointers. However, it'd be one mighty coding task - just dimensioning the rgabounds of your SAFEARRAY for the memory read would be a task - and if your array values were Strings, it'd be of an order of magnitude mightier.
An easier, though doubtless slower, option would be to exploit the For Each looping method, which can be applied to an array. Its looping sequence is like so:
arr(1,1)
arr(2,1)
arr(3,1)
arr(1,2)
arr(2,2)
arr(3,2)
etc.
So you'd only need a simple odometer-style index counter.
You could basically iterate every element in the array and if the combination of indexes matched what you wanted, you'd read the element into your extraction array. That would be a much easier task. The code below shows you how you could do this on a multi-dimensional array of unknown dimensions.
Option Explicit
Private Type ArrayBounds
Lower As Long
Upper As Long
Index As Long
WantedDimension As Boolean
DiscardIndex As Long
End Type
Public Sub RunMe()
Dim arr As Variant
Dim result As Variant
arr = CreateDummyArray
result = Extract(arr, 1, 3, 11)
End Sub
Private Function Extract(arr As Variant, i1 As Integer, i2 As Integer, ParamArray ov() As Variant) As Variant
Dim d As Long
Dim bounds() As ArrayBounds
Dim i As Long
Dim v As Variant
Dim ovIndex As Long
Dim doExtract As Boolean
Dim result() As Variant
'Dimension the output array
ReDim result(LBound(arr, i1) To UBound(arr, i1), LBound(arr, i2) To UBound(arr, i2))
'Get no. of dimensions in array
d = GetDimension(arr)
'Now we know the number of dimensions,
'we can check that the passed parameters are correct
If (i1 < 1 Or i1 > d) Or (i2 < 1 Or i2 > d) Then
MsgBox "i1/i2 - out of range"
Exit Function
End If
If UBound(ov) - LBound(ov) + 1 <> d - 2 Then
MsgBox "ov - wrong number of args"
Exit Function
End If
'Resise and populate the bounds type array
ReDim bounds(1 To d)
ovIndex = LBound(ov)
For i = 1 To d
With bounds(i)
.Lower = LBound(arr, i)
.Upper = UBound(arr, i)
.Index = .Lower
.WantedDimension = (i = i1) Or (i = i2)
If Not .WantedDimension Then
.DiscardIndex = ov(ovIndex)
ovIndex = ovIndex + 1
'Check index is in range
If .DiscardIndex < .Lower Or .DiscardIndex > .Upper Then
MsgBox "ov - out of range"
Exit Function
End If
End If
End With
Next
'Iterate each member of the multi-dimensional array with a For Each
For Each v In arr
'Check if this combination of indexes is wanted for extract
doExtract = True
For i = 1 To d
With bounds(i)
If Not .WantedDimension And .Index <> .DiscardIndex Then
doExtract = False
Exit For
End If
End With
Next
'Write value into output array
If doExtract Then
result(bounds(i1).Index, bounds(i2).Index) = v
End If
'Increment the dimension index
For i = 1 To d
With bounds(i)
.Index = .Index + 1
If .Index > .Upper Then .Index = .Lower Else Exit For
End With
Next
Next
Extract = result
End Function
Private Function GetDimension(arr As Variant) As Long
'Helper function to obtain number of dimensions
Dim i As Long
Dim test As Long
On Error GoTo GotIt
For i = 1 To 60000
test = LBound(arr, i)
Next
Exit Function
GotIt:
GetDimension = i - 1
End Function
I'm trying to get a 2D array of size [x][3] filled. X is just the size of the sheet (number of rows) and there are 3 columns which I am interested in. The columns are not near each other, for instance arr[i][0] should be filled from column AA, arr[i][1] should come from column K, and arr[i][2] needs to be from columns L.
I tried assigning it the following way, but got an error in the array value assignment.
Any help on this would be greatly appreciated!
Code:
Sub SOC_work()
'Trying to sort each of the disciplines further, by Stage of Construction
Dim ar_SOC() As Variant
Dim int_NumRows As Long
Dim i_counter As Long
Dim j_Counter As Long
Dim lite As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("AVEVA_PBOM_PARTS").Select
'Redimension the array size to the amount of parts in the PBOM
int_NumRows = ActiveSheet.UsedRange.Rows.count - 1
ReDim ar_SOC(int_NumRows, 3)
'now assignt he range into the array space
lite = Range("AA2", Range("AA2").End(xlDown))
ar_SOC[][1]=lite
End Sub
Is there any way to do this without looping through the entire column?
As described in the comments, you can fill three 2-D arrays. You can then populate a fourth array from the three arrays, like below.
Sub populateArray()
Dim arrColOne() As Variant, arrColTwo() As Variant, arrColThree() As Variant
Dim arrAllData() As Variant
Dim i As Long
arrColOne = Range("A2:A" & lrow(1)) 'amend column number
arrColTwo = Range("D2:D" & lrow(4))
arrColThree = Range("G2:G" & lrow(7))
ReDim arrAllData(1 To UBound(arrColOne, 1), 2) As Variant
For i = 1 To UBound(arrColOne, 1)
arrAllData(i, 0) = arrColOne(i, 1)
arrAllData(i, 1) = arrColTwo(i, 1)
arrAllData(i, 2) = arrColThree(i, 1)
Next i
End Sub
Public Function lrow(colNum As Integer) As Long
lrow = Cells(Rows.Count, colNum).End(xlUp).Row
End Function
The above will require all 3 columns to be the same length (otherwise populating the last array will not work); this is due to the fourth array being redimensioned to contain the number of elements contained in the first array.
Testing with 250,000 rows of data, the fourth array populated in 0.43 seconds.
How lenient are you with the array you get in return? I can get you a Array(col)(row)-style array, without having to loop to get it, if that works. Note that's not Array(col, row), by the way. It's a single-dimensional array of columns, with each element containing a single-dimensional array of row values. If you're okay with that, you can do this:
Dim a(1 To 3)
a(1) = WorksheetFunction.Index(WorksheetFunction.Transpose(Range("AA2:AA10")), 1, 0)
a(2) = WorksheetFunction.Index(WorksheetFunction.Transpose(Range("K2:K10" )), 1, 0)
a(3) = WorksheetFunction.Index(WorksheetFunction.Transpose(Range("L2:L10" )), 1, 0)
Then you could access your array items like so:
Debug.Print UBound(a) ' Number of columns (3)
Debug.Print UBound(a(1)) ' Number of rows in column 1
Debug.Print a(1)(3) ' Value of column 1 (AA), row 3
The Index() function can return a 1D array but only in the rows direction. So, you need to combine it with Transpose() to return a 1D column array. That's all the code above is doing.
What about an array of arrays?
Sub NoLoop()
Dim R1 As Range, R2 As Range, R3 As Range
Dim Arr1() As Variant, Arr2() As Variant, Arr3() As Variant
Dim LR As Long
LR1 = Cells(Rows.Count, "AA").End(xlUp).Row
LR2 = Cells(Rows.Count, "K").End(xlUp).Row
LR3 = Cells(Rows.Count, "L").End(xlUp).Row
Set R1 = Range(Cells(1, "AA"), Cells(LR1, "AA"))
Set R2 = Range(Cells(1, "K"), Cells(LR2, "K"))
Set R3 = Range(Cells(1, "L"), Cells(LR3, "L"))
Arr1 = R1.Value
Arr2 = R2.Value
Arr3 = R3.Value
ArrArr = Array(Arr1, Arr2, Arr3)
End Sub
With this you can call your values using:
MyVal = ArrArr(0)(1,1)
MyVal = ArrArr(0)(2,1)
MyVal = ArrArr(1)(1,1)
Where the first number is for the array (starts from 0 and ends with 2) and the second number is for row/cell of the range used to fill array.
The third number is always 1 (because adding a range to an array returns a bidimensional array)
With this code you can also have different dimensions for each column so to save memory.
I have a repeating list of 145 categories, with 15 columns of data for each category.
I am consolidating this list by reducing the number of categories to 24 and adding the corresponding data.
For example,
If initially I had Categories A B C D E F G and I consolidated, I would add all the values in A and, say F, to get a new category.
Another issue is that all these 145 categories are repeated over 60 time periods. So I have to consolidate the data separately for each time period.
To do this, I am trying to use arrays.
Sub CategoriesToSectors()
Dim k As Integer
Dim j As Integer
Dim p As Integer
Dim Destination As Range
' p is just a filler/dummy variable until I later decide which categories go into which sector
Dim CategoryData(144, 14) As Long
Dim SectorData(23, 14) As Long
k = 0
' k should go Upto 60
' I first copy the data from a range in the first worksheet into the array CategoryData
' Then I move 145 rows down for the next time-period's data and repeat this whole process
While k < 60
Sheets("ReformattedData").Select
Range("B1:P145").Select
ActiveCell.CurrentRegion.Offset(k * 145, 0).Select
CategoryData = Selection.Value
For j = 0 To 14
SectorData(0, j) = CategoryData(1, j) + CategoryData(6, j) + CategoryData(8, j) + CategoryData(13, j)
For p = 1 To 23
SectorData(p, j) = CategoryData(15, j) + CategoryData(19, j) + CategoryData(31, j) + CategoryData(44, j)
Next p
Next j
' paste consolidated sectordata array one below another in SectorData worksheet
Sheets("SectorData").Select
Range("B2").Select
Set Destination = ActiveCell.Offset(k * 25, 0)
Destination.Resize(UBound(SectorData, 1), UBound(SectorData, 2)).Value = SectorData
Wend
End Sub
As you can see, what I am doing is first trying to copy the first range block into the CategoryData array. Then, I am combining the data into the sector array - I have just used repeated values to test it - the for loop with p should not exist. I will eventually use 24 different statements to create the SectorData Array.
Then I paste the Consolidated data onto another sheet. I Go back to the first sheet and move my selection down for the next range block (145 cells below the first cell) then I select this data and repeat.
This does not seem to work - error in entering data into the first array - CategoryData.
Help would be appreciated.
Thank you
In order to copy a Range into a VBA array you have to use a Variant:
Dim CategoryData() As Variant
'or just CategoryData As Variant (no brackets)
'then the following will work
CategoryData = Selection.Value
Once you've transferred the data you can examine UBound for CategoryData.
There is a useful discussion here at cpearson.
You can set a Range to an array (SectorData in your example) without it being a Variant, as long as the dimensions are the same.
Try this:
Sub RangeToArray()
Dim NewArray As Variant
Dim SourceRange As Range
Set SourceRange = Selection.CurrentRegion
NewArray = SourceRange.Value
Stop 'to check the result in Immediate Window
End Sub
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