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
Related
Suppose I have data in range A1:A100. I would like to split each cell in the range to multiple columns, by a fixed width, eg (0-10,10-15,15-37). I could use the Text-to-Columns function in both vba and excel itself.
My question is, if i pass the range to an array first in VBA:
Dim my Array as Variant
myArray = Range("A1:A100").value
How would i apply the following logic:
myNewArray = Array(myArray(0,10),myArray(10,15),myArray(15,37))
or maybe like this:
for i=1 to 100
myNewArray(i,1) = mid(myArray(i),0,10)
myNewArray(i,2) = mid(myArray(i),10,5)
myNewArray(i,3) = mid(myArray(i),15,22)
next
which would result in a new array of 100 rows by 3 columns, but having split the initial data at the specified points, like how a Text-to-Column approach would. But these approaches don't seem to work.
I have tried searching for answer to this but can't seem to find anything
Any help would be appreciated,
thanks
In addition to Scott 's correct hint in comment you could use one datafield array only (based on three columns) and do a reverse loop splitting the first "column":
Option Explicit
Sub Split_them()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet") ' << change to your sheet name
Dim i As Long, j As Long
Dim v
Dim a(): a = Array(0, 11, 16, 38) ' Fixed Widths (first item zero)
v = ws.Range("A1:C100")
For i = 1 To UBound(v, 1)
For j = 3 To 1 Step -1
v(i, j) = Mid(v(i, 1), a(j - 1) + 1, a(j) - a(j - 1))
Next j
Next i
' write back to sheet
ws.Range("A1:C100").Offset(0, 2) = v
End Sub
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
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.
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.
hey I'm new to vba and I already tried searching for an answer to my question.
I want to fill a dynamic array with specific arrays which can be changed in the table. for that I created the following code:
Sub ZellenArrayReader()
Dim boom() As Variant
Dim rowsboom As Integer
Dim sh As Variant
sh = "TAB1"
Worksheets(sh).Range("A1").Select
rowsboom = Selection.CurrentRegion.Rows.Count - 2
ReDim boom(0 To rowsboom)
For i = LBound(boom) To i = UBound(boom)
boom(i) = Worksheets(sh).Cells(i + 2, 1)
Next i
Cells(10, 5).FormulaR1C1 = boom(0)
Cells(10, 1).FormulaR1C1 = boom(1)
End Sub
The for part is the on ewhich is not working correctly. It runs the code just one even if the Upperbound of the array is 4 or 5.
You need to change your For ... Next loop to:
For i = LBound(boom) To UBound(boom)
boom(i) = Worksheets(sh).Cells(i+2, 1)
Next i
Small modification, It work well.
Private Sub ZellenArrayReader()
Dim boom() As Variant
Dim rowsboom As Integer
Dim sh As String
sh = "TAB1"
Sheets(sh).Range("A1").Select
rowsboom = Selection.CurrentRegion.Rows.Count - 2
ReDim boom(0 To rowsboom)
For i = 0 To UBound(boom) Step 1
boom(i) = Sheets(sh).Cells(i + 2, 1)
Next i
Cells(10, 5).FormulaR1C1 = boom(0)
Cells(10, 1).FormulaR1C1 = boom(1)
End Sub
As others have answered, the i=UBound(boom) part of your for loop is causing the problem. If boom had 1 element, that would return True(i=0 and UBound(boom)=0) and it would be like For i = LBound(boom) to -1 (True is -1 when cast as a Long). That would loop zero times. In your case, you have at least two elements, so i=UBound(boom) returns False. That's like For i = LBound(boom) to 0 which is why it only executes once.
The Range.Value property returns a two dimensional array and is generally faster than looping through an array and filling it with values from cells. The lower bound of an array assigned via Range.Value is 1, not zero. Here's a rewrite of the code without the loop.
Sub ZellenArrayReader()
Dim vBoom As Variant
Dim sh As Worksheet
Dim rCurrReg As Range
Set sh = ThisWorkbook.Worksheets("TAB1")
Set rCurrReg = sh.Range("A1").CurrentRegion
vBoom = rCurrReg.Resize(rCurrReg.Rows.Count - 2).Value
sh.Cells(10, 5).Value = vBoom(1, 1)
sh.Cells(10, 1).Value = vBoom(2, 1)
End Sub