Cleaning up an array - arrays

I have a very large array in VBA which includes a lot of 0 values that I'd like to remove. Something like this:
A B C 12345
D E F 848349
G H I 0
J K L 0
M N O 0
P Q R 4352
S T U 0
V W X 0
I would like to be able to quickly/easily strip out all rows from this array that have a zero in the 4th column, resulting in something like this:
A B C 12345
D E F 848349
P Q R 4352
This array has 100,000 or so rows, that hopefully gets down to a number closer to 20,000 or 30,000 rows instead after processing.
I assume iterating through every entry will prove very time-consuming.
Is there another way that is faster?

I'm not aware of any other way in VBA than to loop through the array and write another array/list.
What makes it trickier is that your array looks to be two-dimensional and VBA will only allow you to redim the last dimension. From the look of your data, you'd want to redim the first dimension as you iterate through your array.
There are several solutions:
Iterate your data twice - once to get the array size (and probably to store the relevant row numbers) and a second time to transfer the raw data into your new data.
Iterate once and just reverse your dimensions (ie row is last).
Use an array of arrays, so that each array only has one dimension).
Use a Collection which doesn't need to be dimensioned - this would be my preferred option.
Option 4 would look like this (I've assumed your array is zero based):
Dim resultList As Collection
Dim r As Long
Set resultList = New Collection
For r = 0 To UBound(raw, 1)
If raw(r, 3) <> 0 Then
resultList.Add Array(raw(r, 0), raw(r, 1), raw(r, 2), raw(r, 3))
End If
Next
If you have to write to a new array, then here's an example of Option 1:
Dim rowList As Collection
Dim result() As Variant
Dim r As Long
Dim c As Long
Dim v As Variant
Set rowList = New Collection
For r = 0 To UBound(raw, 1)
If raw(r, 3) <> 0 Then
rowList.Add r
End If
Next
ReDim result(rowList.Count - 1, 3) As Variant
c = 0
For Each v In rowList
result(c, 0) = raw(v, 0)
result(c, 1) = raw(v, 1)
result(c, 2) = raw(v, 2)
result(c, 3) = raw(v, 3)
c = c + 1
Next

Okay, it's all off-sheet, so all the arrays are zero-based. To test this set-up, I created a worksheet with four columns, as per your data and using random numbers in the fourth column. I saved this to a text file (TestFile.txt), then read it in to be able to get a zero-based array (Excel ranges are 1-based when you take them into an array). I saved 150000 rows to the text file to properly stress the routine. Yes, I have an SSD and that would affect the 2s run time, but I'd still expect it to run in <10s on a spinning HDD, I think.
Anyway, here's the code (requires a VBA reference to Microsoft Scripting Runtime purely to read in the file):
Public Function ReturnFilteredArray(arrSource As Variant, _
strValueToFilterOut As String) As Variant
Dim arrDestination As Variant
Dim lngSrcCounter As Long
Dim lngDestCounter As Long
ReDim arrDestination(UBound(arrSource, 1) + 1, UBound(arrSource, 2) + 1)
lngDestCounter = 1
For lngSrcCounter = LBound(arrSource, 1) To UBound(arrSource, 1)
' Assuming the array dimensions are (100000, 3)
If CStr(arrSource(lngSrcCounter, 3)) <> strValueToFilterOut Then
' Hit an element we want to include
arrDestination(lngDestCounter, 1) = arrSource(lngSrcCounter, 0)
arrDestination(lngDestCounter, 2) = arrSource(lngSrcCounter, 1)
arrDestination(lngDestCounter, 3) = arrSource(lngSrcCounter, 2)
arrDestination(lngDestCounter, 4) = arrSource(lngSrcCounter, 3)
lngDestCounter = lngDestCounter + 1
End If
Next
ReturnFilteredArray = arrDestination
End Function
Sub TestRun()
Dim fso As FileSystemObject
Dim txs As TextStream
Dim arr As Variant
Dim arr2 As Variant
Dim lngCounter As Long
Debug.Print Now()
Set fso = New FileSystemObject
Set txs = fso.OpenTextFile("E:\Users\Thingy\Desktop\TestFile.txt", ForReading)
arr = Split(txs.ReadAll, vbNewLine)
ReDim arr2(UBound(arr), 3)
For lngCounter = 0 To UBound(arr) - 1
arr2(lngCounter, 0) = Split(arr(lngCounter), vbTab)(0)
arr2(lngCounter, 1) = Split(arr(lngCounter), vbTab)(1)
arr2(lngCounter, 2) = Split(arr(lngCounter), vbTab)(2)
arr2(lngCounter, 3) = Split(arr(lngCounter), vbTab)(3)
Next
arr2 = ReturnFilteredArray(arr2, "0")
Range("L2").Resize(UBound(arr2, 1), 5) = arr2
Debug.Print Now()
End Sub
There are a number of assumptions in there, not least the dimensions. Note the difference in the second dimension counter between arrDestination and arrSource. That's to do with Excel being 1-based and normal arrays being 0-based.
Also, when I'm writing out the array, I needed to bump up the second dimension to 5 in order to get all of the array out to the sheet. I wasn't able to trim off the empty elements since ReDim Preserve only works on the uppermost dimension (columns) and it's the first dimension (rows) that's changing here.
Anywho, this should serve as a reminder that despite its faults Excel is pretty amazing.

Related

VBA: Write array to sheet in a block (one memory access)

I have a large array (45000 elements) that i need to write down in an excel sheet. However this is taking way to long when looping over the values (requesting a memory access for each value)
(I have already disabled features like screen updating)
I've found some ways to do it using the Variant type (french : https://www.lecfomasque.com/vba-rediger-des-macros-plus-rapides/) However i must be messing up at some point, see example code
Sub test()
Dim table(4) As Variant
Dim writeArray() As Variant
table(0) = 0
table(1) = 1
table(2) = 2
table(3) = 3
table(4) = 4
writeArray = table
'Supposed to write 0 to A1, 1 to A2,... but not working that way
Range("A1:A5").Value = writeArray
End Sub
This code writes only the first value (0) to the whole range, even if the variant writearray contains also the other values (1,2,3,4).
Any idea (without a memory request for each value) on how to solve this is welcome, Thank you ^-^
EDIT (SOLUTION)-----------------------
Paul's (transpose) and Mikku's (2D-array) solutions seem to work and both provide an tenfold reduction of execution time in my case. The transpose is slighly faster on average.
On this site I found this useful little piece...
Dim Destination As Range
Set Destination = Range("K1")
Destination.Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
You can transpose the array when writing to the worksheet:
Set Destination = Range("K1")
Destination.Resize(UBound(Arr, 2), UBound(Arr, 1)).Value = Application.Transpose(Arr)
Well a 2-D array can do that
Sub test()
Dim table(0 To 4, 1 To 1) As Variant
table(0, 1) = 0
table(1, 1) = 1
table(2, 1) = 2
table(3, 1) = 3
table(4, 1) = 4
Range("A1:A5") = table
End Sub
The underlying problem is that 1D array corresponds to a row in the sheet. So you can put
Range("A1:E1") = table
and it works fine.
If you want to put your array into a column, the easiest way is to use transpose as mentioned by #Paul:
writeArray = Application.WorksheetFunction.Transpose(table)
which gives you a 2D array with five rows and 1 column.
Sub test2()
Dim table(0 To 4) As Variant
Dim writeArray() As Variant
table(0) = 0
table(1) = 1
table(2) = 2
table(3) = 3
table(4) = 4
writeArray = Application.WorksheetFunction.Transpose(table)
Debug.Print ("ubound=" & UBound(writeArray, 1))
Debug.Print ("ubound=" & UBound(writeArray, 2))
Range("A1:A5") = writeArray
Range("A1:E1") = table
End Sub

Excel VBA - insert rows from range to array based on criteria; then populate certain ranges on another sheet with data from array

My VBA knowledge is very limited. I looked through the questions on StackOverflow and googled for a couple of days, but I couldn't find the solution to my problem.
So, I am working on an Excel macro. I have a range A3:H7136. Certain cells in column A have a value of 1; the rest are blank. Cells in columns D, E, F, G, H may be blank or may contain text or numbers.
What I am trying to do is take the range A3:H7136 and put the data into an array; exclude rows with blank A cells AND with blank D cells; convert to a "final" array, from where the data from columns 2, 4 and 8 will be pasted into ranges D309:D558, G309:G558, J309:J558 on another worksheet.
So far I've got the following:
Private Sub CommandButton1_Click()
Dim RowArray() As Long
Dim my_array1 As Range
Dim my_array2 As Variant
Dim i As Integer
Set my_array1 = ThisWorkbook.Worksheets("ETC").Range("A3:H7136")
my_array2 = my_array1.Value
For i = 1 To UBound(my_array2)
If my_array2(i, 1) = 1 And my_array2(i, 4) <> "" Then
RowArray(x) = i: x = x + 1
End If
Next i
Sheets("Allocation").Range("D309:D558") = Application.Index(my_array2, 1, Array(4))
Sheets("Allocation").Range("J309:J558") = Application.Index(my_array2, 1, Array(2))
End Sub
I stopped there because I realized that the code pastes #value! into the ranges on another worksheet. This code is "Frankenstein-ed" from several forums so it might look very weird to a professional. I need help getting the code to work. I also have several questions:
If the "final" array is 100% blank (which can happen), how do I get rid of #Value! on another worksheet?
In the last two rows it looks to me like I am using the original my-array2, and not the "final" filtered version of it. Should I declare the "final" array?
My paste range is only 250 rows; there is no way the number of non-blank rows in the array will ever exceed 250 rows, however, will that difference be a problem?
Thanks in advance!
A couple things:
RowArray's size was never declared so it would throw an out of bounds error.
You can use three array for the outputs in the loop then directly assign the arrays to the needed areas.
Private Sub CommandButton1_Click()
Dim DArray() As Variant
Dim GArray() As Variant
Dim JArray() As Variant
Dim my_array2 As Variant
Dim i As Long, x As Long
Dim cnt As Long
cnt = ThisWorkbook.Worksheets("ETC").Evaluate("COUNTIFS(A3:A7136,1,D3:D7136,""<>"")")
If cnt > 0 Then
ReDim DArray(1 To cnt, 1 To 1) As Variant
ReDim GArray(1 To cnt, 1 To 1) As Variant
ReDim JArray(1 To cnt, 1 To 1) As Variant
my_array2 = ThisWorkbook.Worksheets("ETC").Range("A3:H7136").Value
x = 1
For i = 1 To UBound(my_array2)
If my_array2(i, 1) = 1 And my_array2(i, 4) <> "" Then
DArray(x, 1) = my_array2(i, 4)
GArray(x, 1) = my_array2(i, 4)
JArray(x, 1) = my_array2(i, 8)
x = x + 1
End If
Next i
Sheets("Allocation").Range("D309").Resize(UBound(DArray, 1), 1).Value = DArray
Sheets("Allocation").Range("G309").Resize(UBound(GArray, 1), 1).Value = GArray
Sheets("Allocation").Range("J309").Resize(UBound(JArray, 1), 1).Value = JArray
End If
End Sub

extract user-defined dimensions from multidimension array

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

WorksheetFunction.Small: How to define Array

I want to apply the WorksheetFunction.Small on another array as such:
ReDim ArrSmall(Iterations, 20)
For l = 1 To Iterations
For k = 1 To 20
ArrSmall(l, k) = WorksheetFunction.Small(ArrResult(l, k), l)
Next k
Next l
I know this part: ArrResult(l,k), is wrong because it asks for a range instead of a single number which I'm inputting. However, I am unsure how to define the range in the code.
Is this possible or do I have to output the values on a TempSheet, then back into an array? I think a solution is to call the whole column of the array but I do not know how.
EDIT:
I managed to write a dummy code which does exactly what I want but the weird part is when I apply the same to my original code, all the values get mixed up (it literally makes up values AFAIK). See below for code:
Sub test()
ReDim ArrTest(10, 1)
ReDim ArrSmall(10, 1)
ArrTest = Range("A1:A10")
For i = 1 To 10
ArrSmall(i, 1) = WorksheetFunction.Small(ArrTest, i)
Cells(i, 2) = ArrTest(i, 1)
Cells(i, 3) = ArrSmall(i, 1)
Next i
Trying to clear the whole array before a new loop. Maybe that fixes it...
If you were looking to take the smallest value of each column (which is the same as Min) from say A1:T20 then you could use TRANPOSE (to work with columns rather than rows) and then INDEX to separate each column, i.e.
The IF test is to avoid applying SMALL to an empty array (else an error results).
Sub B()
Dim ArrSmall(1 To 1, 1 To 20)
Dim lngCnt As Long
Dim ArrResult
ArrResult = Application.Transpose([a1:t20].Value2)
For lngCnt = 1 To UBound(ArrResult, 2)
If Application.Count(Application.Index(ArrResult, lngCnt)) > 0 Then _
ArrSmall(1, lngCnt) = WorksheetFunction.Small(Application.Index(ArrResult, lngCnt), 1)
Next
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