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
Related
I am trying to create a TextSplit function in Excel that can accept either a single reference or a range.
If it is a single string it returns an array of sub strings.
If it is a range it should return an array of sub string arrays.
A single string works but when I pass it a single column range it give me a #VALUE! error.
The commented lines work.
If I store the result of Array to arr Excel displays a grid of "test" strings.
If instead I set TextSplit to just arr(1) I get a single array of substrings similar to the single string version.
Function TextSplit(text, delimiter)
If IsArray(text) Then
Dim arr() As Variant: ReDim arr(0 To text.Count - 1)
For i = 1 To text.Count
arr(i-1) = Split(text(i), delimiter)
'arr(i-1) = Array("test", "test")
Next
TextSplit = arr
'TextSplit = arr(1)
Else
TextSplit = Split(text, delimiter)
End If
With the help of a different question Array and Split commands to create a 2 dimensional array
I was able to work your question out a bit, however I'm still unable to fill out the array from the cell where you'd call the function like with your single string which fills out in the columns next to it.
If it's for a column, you could just autofill text.split(cell,delimiter) if you're working from Excel.
If you're working from out vba and want to return the split array (2D like #Tim said) back to a sub:
Sub testingTextSplitter()
Dim arr As Variant, tArr As Variant
Dim testStr As String
testStr = Range("A1").Value 'Testing single cell
Range("G2").Value = TextSplit(testStr, "-")
arr = Range("A1:A8").Value
tArr = TextSplit(arr, "-")
For i = 0 To UBound(tArr, 1)
For j = 0 To UBound(tArr, 2)
Cells(i + 3, j + 3).Value = "'" & tArr(i, j) 'fills out from Range("C3"), adjust as needed
' This writing out is basically the same as fillingdown the formule of text.split() btw
Next j
Next i
End Sub
With the Function
Function TextSplit(tArray As Variant, delimiter As String) As String()
If IsArray(tArray) Then
Dim uBoundInput As Long, uBoundCells As Long 'I couldn't get your arr.Count to work on my end so gotta use the UBound
Dim arr() As String, testArr() As String
Dim i As Long, j As Long, maxColumns As Long
uBoundInput = UBound(tArray)
maxColumns = 0
For i = 0 To uBoundInput - 1
Debug.Print (tArray(i + 1, 1))
testArr = Split(tArray(i + 1, 1), "-")
uBoundCells = UBound(testArr)
If maxColumns < uBoundCells Then
maxColumns = uBoundCells
End If
Next i
ReDim arr(0 To uBoundInput - 1, 0 To maxColumns)
For i = 0 To uBoundInput - 1
testArr = Split(tArray(i + 1, 1), "-")
For j = 0 To UBound(testArr)
arr(i, j) = testArr(j)
Next j
Next i
TextSplit = arr()
Else
TextSplit = Split(tArray, delimiter)
End If
End Function
I'm quite new to VBA as well so apologies in advance for redundancies like not filling testArray when figuring out the maxColumns, I couldn't figure that one out. First time working with 2D arrays.
Other question that might help:
VBA UDF Return Array
(I tried using the array formulay with {} but got same Value error as before)
Hope this helps.
I don't know what happened, but the array branch of my code is now working. I have been messing with a few things, but I am not sure why it is working. The "As Variant()" declaration is new from the above code, but that may have been omitted before. (This code is on my work machine but I wrote the original post from my personal computer so I couldn't copy and paste. I am on my work computer now.)
The only other change that I made was to the index values of the arr array.
Thanks for your help, not sure what was wrong or how it got fixed though.
Function TextSplit(text, delimiter) As Variant()
If IsArray(text) Then
Dim arr() As Variant: ReDim arr(1 To text.Count)
For i = 1 To text.Count
arr(i) = Split(text(i), delimiter, -1, 1)
Next
TextSplit = arr
Else
TextSplit = Split(text, delimiter, -1, 1)
End If
End Function
I have 2 arrays taken from 2 ranges in a sheet. I'm trying to create a third array that contains only the values contained in array 1 that are missing in array 2 (I found this code online).
Array 2´s size will vary and depends on this code:
Dim iListaIncompleta() As Variant
Dim iCountLI As Long
Dim iElementLI As Long
iCountLI = Range("B1").End(xlDown).Row
ReDim iListaIncompleta(iCountLI)
For iElementLI = 1 To iCountLI
iListaIncompleta(iElementLI - 1) = Cells(iElementLI, 2).Value
Next iElementLI
and Array 1's size is always from A1:A7, and I use this code to create it:
Dim iListaCompleta() As Variant
Dim iElementLC As Long
iListaCompleta = Range("A1:A7")
This is the original code I found online to extract missing values:
Dim v1 As Variant, v2 As Variant, v3 As Variant
Dim coll As Collection
Dim i As Long
'Original Arrays from the code:
v1 = Array("Bob", "Alice", "Thor", "Anna") 'Complete list
v2 = Array("Bob", "Thor") 'Incomplete list
Set coll = New Collection
For i = LBound(v1) To UBound(v1)
If v1(i) <> 0 Then
coll.Add v1(i), v1(i) 'Does not add value if it's 0
End If
Next i
For i = LBound(v2) To UBound(v2)
On Error Resume Next
coll.Add v2(i), v2(i)
If Err.Number <> 0 Then
coll.Remove v2(i)
End If
If coll.Exists(v2(i)) Then
coll.Remove v2(i)
End If
On Error GoTo 0
Next i
ReDim v3(LBound(v1) To (coll.Count) - 1)
For i = LBound(v3) To UBound(v3)
v3(i) = coll(i + 1) 'Collections are 1-based
Debug.Print v3(i)
Next i
End Sub
However, this code has arrays defined like this:
v1 = Array("Bob", "Alice", "Thor", "Anna")
And the actual arrays I wanna use are defined differently (as you can see in the first two pieces of code). When I try to run the code with them, it displays
Error 9: Subscript out of range.
The code works well as it originally is, but when I try to use MY arrays, it's when I get this error.
Obviously, I've tried it changing the names of the variables (v1 and v2) to my own 2 arrays (iListaCompleta and iListaIncompleta), and still doesn't work.
Any ideas??
Thank you in advance!
Here's a function that can be used to compare arrays of any dimension size to pull out differences and put only the differences in a one-dimensional array:
Public Function ArrayDifference(ByVal arg_Array1 As Variant, ByVal arg_array2 As Variant) As Variant
If Not IsArray(arg_Array1) Or Not IsArray(arg_array2) Then Exit Function 'Arguments provided were not arrays
Dim vElement As Variant
Dim hDifference As Object: Set hDifference = CreateObject("Scripting.Dictionary")
For Each vElement In arg_Array1
If Not hDifference.exists(vElement) Then hDifference.Add vElement, vElement
Next vElement
For Each vElement In arg_array2
If hDifference.exists(vElement) Then
hDifference.Remove vElement
Else
hDifference.Add vElement, vElement
End If
Next vElement
ArrayDifference = hDifference.Keys
End Function
Here's how you would call the function to compare two different arrays. It also includes how to populate the initial arrays using your provided setup:
Sub arrays()
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Dim rList1 As Range: Set rList1 = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim rList2 As Range: Set rList2 = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp))
Dim aList1 As Variant
If rList1.Cells.Count = 1 Then
ReDim aList1(1 To 1, 1 To 1)
aList1(1, 1) = rList1.Value
Else
aList1 = rList1.Value
End If
Dim aList2 As Variant
If rList2.Cells.Count = 1 Then
ReDim aList2(1 To 1, 1 To 1)
aList2(1, 1) = rList2.Value
Else
aList2 = rList2.Value
End If
Dim aList3 As Variant
aList3 = ArrayDifference(aList1, aList2)
MsgBox Join(aList3, Chr(10))
End Sub
I have 2 arrays that I want to combine into a single array of all possible combinations. I then need to loop through all of the combinations and popular arguments for a function. My arrays are not equal in size, and my attempts so far have resulted in a combined array only having 1 pair of values. This is VBA in PowerPoint, not Excel, if that makes a difference to available syntax.
How can I go from this:
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
To this:
arrayCombo(0,0) = "Blue"
arrayCombo(0,1) = "XS"
arrayCombo(1,0) = "Blue"
arrayCombo(1,1) = "S"
...
arrayCombo(15,0) = "Red"
arrayCombo(15,1) = "XL"
And then use a loop to call each pair of values and populate argument values. This code just to illustrate the concept; it's certainly not legit. Pretty sure I need a nested loop here?
For i = 0 To UBound(arrayCombo(i))
nextSubToFire(color, size)
Next i
This is what I've got so far, but it only results in a single pair in my combined array. It's based on this question, but I think I'm either missing something or the sole answer there isn't quite correct. I've looked at other similar questions, but can't wrap my head around doing this with an array compiled in the code rather than the other examples all tailored to Excel.
Option Explicit
Dim arrayColorSize, arrayCombo
Sub CoreRoutine()
Dim arrayColor, arraySize
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
arrayColorSize = Array(arrayColor, arraySize)
arrayCombo = Array(0, 0)
DoCombinations (0)
Dim a As Integer
Dim b As Integer
'For loop comes next once I figure out how to populate the full arrayCombo
End Sub
Sub DoCombinations(ia)
Dim i
For i = 0 To UBound(arrayColorSize(ia)) ' for each item
arrayCombo(ia) = arrayColorSize(ia)(i) ' add this item
If ia = UBound(arrayColorSize) Then
Else
DoCombinations (ia + 1)
End If
Next i
End Sub
Using the Locals window, I see arrayCombo exists, but it only has 1 pair of values in it, which is the last set of pairing options. I see that arrayColorSize has the 2 array sets as I'd expect, so I suspect the DoCombinations sub is missing something.
Any guidance much appreciated!
One way of doing this is to combine the two 1D arrays into a 2D array with 2 columns (as in your example):
Private Function Combine1DArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant
If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then
Err.Raise 5, "Combine1DArrays", "Expected 1D arrays"
End If
'
Dim count1 As Long: count1 = UBound(arr1) - LBound(arr1) + 1
Dim count2 As Long: count2 = UBound(arr2) - LBound(arr2) + 1
Dim i As Long, j As Long, r As Long
Dim result() As Variant
'
ReDim result(0 To count1 * count2 - 1, 0 To 1)
r = 0
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
result(r, 0) = arr1(i)
result(r, 1) = arr2(j)
r = r + 1
Next j
Next i
Combine1DArrays = result
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
You can use it like this for example:
Sub CoreRoutine()
Dim arrayColorSize As Variant
Dim i As Long
Dim color As String
Dim size As String
'
arrayColorSize = Combine1DArrays(Array("Blue", "Green", "Red") _
, Array("XS", "S", "M", "L", "XL"))
For i = LBound(arrayColorSize, 1) To UBound(arrayColorSize, 1)
color = arrayColorSize(i, 0)
size = arrayColorSize(i, 1)
NextSubToFire color, size
Next i
End Sub
Sub NextSubToFire(ByVal color As String, ByVal size As String)
Debug.Print color, size
End Sub
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
I'm creating two arrays based on a range in my Excel sheet:
AdjustedProductionValues,
ProductionTargetValues
I'm creating a third array to hold new values:
FinalProductionValues
I want to loop through AdjustedProductionValues; if the value is 0 I want to assign the value of ProductionTargetValues to a new array FinalProductionValues. Otherwise, I want to assign the value of AdjustedProductionValues to FinalProductionValues.
I keep getting an error of Subscript out of range. I've tried ReDim a couple different ways with no success. I get the error at the If statement.
How do I fix this?
Sub TEST()
Dim AdjustedProductionValues() As Variant
Dim ProductionTargetValues() As Variant
Dim FinalProductionValues() As Variant
ReDim FinalProductionValues(1 To 1) As Variant
Dim i As Integer
'Assigning Adjusted Production and Production Target numbers into lists
Worksheets("SUMMARY").Activate
AdjustedProductionValues = Range(Range("E35"), Range("E35").End(xlToRight))
ProductionTargetValues = Range(Range("E34"), Range("E34").End(xlToRight))
'checking each Adjusted Production value
'if it's 0 then assigns the Adjusted Production value to a new list
'if it's not 0 it assignes the Production Target to the new list
For i = 0 To UBound(AdjustedProductionValues)
ReDim Preserve FinalProductionValues(1 To UBound(FinalProductionValues) + 1) As Variant
If AdjustedProductionValues(i) = 0 Then
FinalProductionValues(UBound(FinalProductionValues)) = ProductionTargetValues(i)
Else
FinalProductionValues(UBound(FinalProductionValues)) = AdjustedProductionValues(i)
End If
Next i
End Sub
UPDATE W/ FIX
I fixed my code with this:
For i = 1 To UBound(AdjustedProductionValues, 2)
ReDim Preserve FinalProductionValues(1 To UBound(FinalProductionValues) + 1) As Variant
If AdjustedProductionValues(1, i) = 0 Then
FinalProductionValues(UBound(FinalProductionValues)) = ProductionTargetValues(1, i)
Else
FinalProductionValues(UBound(FinalProductionValues)) = AdjustedProductionValues(1, i)
End If
Next i
I checked my work by using the following:
Worksheets("Sheet2").Activate
Dim NumRows As Long
Dim NumCols As Long
NumRows = 1
NumCols = UBound(FinalProductionValues, 1) - LBound(FinalProductionValues, 1) + 1
Range("A1").Resize(NumRows, NumCols).Value = FinalProductionValues
Got help checking my code with this link.