※ This question is a continuation of below problem
How to use nested loop for a Matrix cell in excel vba
I would like to pass dynamic Array(arguments), and i was trying below, but it is not working correctly. Could you please help me.
Dim StartrowArr, Startrow1Arr, J As Integer
Dim flRow, dtRow As String
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each cell In filRng
If cell.Value <> "" Then
ftRow = ftRow & cell.Row & ","
End If
Next cell
ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print ftRowNo
For Each cell In dtlRng
If cell.Value <> "" Then
dtRow = dtRow & cell.Row & ","
End If
Next cell
dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print dtRow
StartrowArr = Array(filRowNo) ※ dynamic array args
Startrow1Arr = Array(dtlRowNo)
but after initializing Array(args) like above, it returns error 1004 on [Startrow1, init with 0]. I also tried CInt(ftRow) to typecast to Integer from String. nothings changed. Moreover, log shows that Startrow, Startrow1 got values like below.
Startrow: 2, 4, 7
Startrow1: 2611 ※ should be 2, 6, 11
However, If I initialize the StartrowArr = Array(2,4,7), statically. it works perfect.
How can I pass the arguments correctly to StartrowArr and Startrow1Arr.
To making Dynamic array, use redim preserve .
Sub test()
Dim StartrowArr(), Startrow1Arr(), J As Integer
Dim flRow, dtRow As String
Dim Cell As Range
Dim k As Long, n As Long
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each Cell In filRng
If Cell.Value <> "" Then
'ftRow = ftRow & cell.Row & ","
ReDim Preserve StartrowArr(k)
StartrowArr(k) = Cell.Row
k = k + 1
End If
Next Cell
'ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print Join(StartrowArr, ",")
For Each Cell In dtlRng
If Cell.Value <> "" Then
'dtRow = dtRow & Cell.Row & ","
ReDim Preserve Startrow1Arr(n)
Startrow1Arr(n) = Cell.Row
n = n + 1
End If
Next Cell
'dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print Join(Startrow1Arr, ",")
'StartrowArr = Array(mapRowNo) '※ dynamic array args
'Startrow1Arr = Array(tcRowNo)
End Sub
Related
I think i've got a good start, but I'm having a tough time taking this to the finish line. Could someone help me out?
I have a name column(G) in my spreadsheet. I want to pull the only the last name out of each cell and assign it to an array called name_array.
I know that my If function is working because if I set each name_cell to the LastName variable it substitutes only the lastname in each cell of the column, but I cannot figure out how to assign that to the array.
Here is my code thus far. Can someone please help me out and point out what I'm missing?
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(name_range.Cells.Count)
For Each name_cell In name_range.Cells
Dim Lastname As String
If InStr(name_cell, " ") > 0 Then
Lastname = Split(name_cell, " ")(1)
End If
name_array(n) = lastname.value
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Name Column
Here is another way to achieve what you want without looping. I have commented the code so you should not have a problem understanding it.
BASIC LOGIC
To get the part after SPACE, you can use the formula =IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")
Now applying the formula in the entire range and getting the value using INDEX(FORMULA). You can find the explanation of this method in Convert an entire range to uppercase without looping through all the cells
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long, i As Long
Dim FinalAr As Variant
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("G2:G" & lRow)
'~~> Get all the last names from the range and store them
'~~> in an array in 1 go!
FinalAr = Evaluate("index(IFERROR(MID(" & _
rng.Address & _
",SEARCH("" ""," & _
rng.Address & _
",1),LEN(" & _
rng.Address & _
")-SEARCH("" ""," & _
rng.Address & _
",1)+1),""""),)")
End With
'~~> Check the output
For i = LBound(FinalAr) To UBound(FinalAr)
Debug.Print ">"; FinalAr(i, 1)
Next i
End Sub
IN ACTION
ALTERNATIVE METHODS
Use Text To columns and then store the output in an array
Use Flash Fill to get the last names and then store the output in an array. One drawback of this method is that the names which do not have last name, it will show first name instead of a blank.
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(0 to name_range.Cells.Count-1) '### 0-based array...
For Each name_cell In name_range.Cells
If InStr(name_cell, " ") > 0 Then
name_array(n) = Split(name_cell, " ")(1) 'simplify...
End If
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Solution using Filter() (values with missing lastnames are excluded):
Sub ExtractLastNames()
Dim arr, name_array, i
arr = WorksheetFunction.Transpose(Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)) 'first, get the horizontal one-dimentional array from cells
name_array = Filter(arr, " ", True) 'second, filter out one-word and empty elements
For i = LBound(name_array) To UBound(name_array)
name_array(i) = Split(name_array(i))(1) 'third, replace name_array values with extracted lastnames
Next
Range("H2").Resize(UBound(name_array) + 1) = WorksheetFunction.Transpose(name_array) ' output
End Sub
Last Names to Array
The following will consider the substring after the last occurring space as the last name.
Option Explicit
Sub create_namear()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim nRange As Range
Set nRange = ws.Range("G2:G" & ws.Range("G" & ws.Rows.Count).End(xlUp).Row)
Dim rCount As Long: rCount = nRange.Rows.Count
Dim nArray() As String: ReDim nArray(0 To rCount - 1)
Dim nCell As Range
Dim n As Long
Dim nmLen As Long
Dim LastSpacePosition As Long
Dim nmString As String
Dim LastName As String
For Each nCell In nRange.Cells
nmString = CStr(nCell.Value)
If InStr(1, nmString, " ") > 0 Then
LastSpacePosition = InStrRev(nCell.Value, " ")
nmLen = Len(nmString)
If LastSpacePosition < nmLen Then
LastName = Right(nmString, nmLen - LastSpacePosition)
nArray(n) = LastName
n = n + 1
End If
End If
Next nCell
If n = 0 Then Exit Sub
If n < rCount Then
ReDim Preserve nArray(0 To n - 1)
End If
Debug.Print "[" & LBound(nArray) & "," & UBound(nArray) & "]" _
& vbLf & Join(nArray, vbLf)
End Sub
Extension on Siddharth' s formula evaluation
These additions to Siddharth's valid code can be helpful, if there are less than 2 data rows in order to avoid
an unwanted evaluation of the title row 1:1 (in case of no data at all, see section 1.b) - This can be prevented by correcting a resulting row number lRow of only 1 to the actual data row start of 2.
Error 9 Subscript out of range (in case of a single element; see section 3.b) - Note that this requires to transform a 1-dim result to a 2-dim results array by means of a adequately dimensioned tmp array.
Furthermore I simplified the formula building to avoid repeated rng.Address insertions just to show another way of doing it (see section 2.).
Sub GetLastName()
'0. Set this to the relevant sheet
Dim ws As Worksheet: Set ws = Sheet1
With ws
'1. Define data range
'1. a) Find last row in col G
Dim lRow As Long
lRow = .Range("G" & .Rows.count).End(xlUp).Row
'1. b) Provide for empty data set ' << Added to avoid title row evaluation
If lRow = 1 Then lRow = 2
'1. c) Set your range
Dim rng As Range: Set rng = .Range("G2:G" & lRow)
'2. Define formula string parts ' << Modified for better readibility
Dim FormulaParts()
FormulaParts = Array("INDEX(IFERROR(MID(", _
",SEARCH("" "",", _
",1),LEN(", _
")-SEARCH("" "",", _
",1)+1),""""),)")
'3. Assign last names to 2-dim array results
'3. a) Get all the last names from the range and store them
Dim results
results = Evaluate(Join(FormulaParts, rng.Address))
End With
'3.b) Provide for single results '<< Added to avoid Error 9 Subscript o/Rng
If UBound(results) = 1 Then '<< Force single element into 2-dim array
Dim tmp(1 To 1, 1 To 1)
tmp(1, 1) = results(1)
results = tmp
End If
'h) Display in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print ">"; results(i, 1)
Next i
'i) Write last names to target '<< Added to demonstrate writing back
ws.Range("H2").Resize(UBound(results), 1) = results
End Sub
I am trying to set an array to a set of ranges. I want to run through each of my sheets, starting at the 5th from the left and select the cell to the right of wherever it finds the text "Total" in column. then the last part is just taking this as it winds through the sheets and creates a string which when placed in the sheet "Final Budget", it acts like a formula and sums up all the values in that cell.
I am receiving the Run-time error '9' of subscript out of range. I have used the index property of Worksheets before so I believe I am doing that correctly, but am not sure why it cannot recognize the subscript.
Application.ScreenUpdating = False
Dim EmpFinal() As Variant
Dim total_1() As Variant
Dim total_2() As Variant
Dim totalAddress() As Variant
iSheets = Sheets.count
For i = 5 To iSheets - 1
Set total_1(i) = Worksheets(i).Range("D:D")
Set total_2(i) = total_1(i).Find("Total")
totalAddress(i) = Cells(total_2(i).Row, total_2(i).Column + 1).Address(0, 0)
Formula = "=SUM("
Formula = Formula & Sheets(i).Name & "!" & totalAddress(i) & ","
Next i
Formula = Left(Formula, Len(Formula) - 1) & ")"
Worksheets("Final Budget").Range("I1").Formula = Formula
Application.ScreenUpdating = True
you do not need the arrays as you are passing the values to the string inside the loop:
Application.ScreenUpdating = False
Dim EmpFinal As Variant
Dim total_1 As Range
Dim total_2 As Range
Dim totalAddress As string
Dim iSheets as Long
iSheets = Sheets.count
Formula = "=SUM("
Dim i as Long
For i = 5 To iSheets - 1
Set total_1 = worksheets(i).Range("D:D")
Set total_2 = total_1.Find("Total")
If Not total_2 is Nothing then
totalAddress = worksheets(i).Cells(total_2.Row, total_2.Column + 1).Address(0, 0)
Formula = Formula & "'" & workSheets(i).Name & "'!" & totalAddress & ","
End If
Next i
Formula = Left(Formula, Len(Formula) - 1) & ")"
Worksheets("Final Budget").Range("I1").Formula = Formula
Application.ScreenUpdating = True
Please look at my sample data and code to understand what I'm trying to do.
I need to use the value of Cells(, 3) to define a range to populate a Trialnumber(18) array. I need the array to iterate through a For loop, to count filled cells in column H for each trial and print the count to column T in the last row of each trial. I will also need the array for further data analysis in future(Unless someone can come up with a better solution).
At the moment I am experimenting with 3 modules of code, trying to get the desired solution.
Module 2 is the only one with no errors, and prints the value in the right cell, but it is printing the total filled cell count (562), rather than per trial (expected value = 1 or 2).
Module 1 is as follows:
Sub dotcountanalysis()
Dim startpoint As Long
startpoint = 1
Dim lastrow As Long
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
Dim i As Long
With Worksheets("full test")
For i = 1 To 18
For n = startpoint To lastrow + 1
If Cells(n, 3).Value <> "Trial, " & CStr(i) Then
Dim nMinusOne As Long
nMinusOne = n - 1
Dim trialCount As Long
'Set Trialnumber(i-1) = Range(cells(startpoint, 3), cells(n-1, 3))
trialCount = Application.WorksheetFunction.CountA(Range("H" & CStr(startpoint) & ":" & "H" & CStr(nMinusOne)))
Range("T" & CStr(startpoint) & ":" & "T" & CStr(nMinusOne)).Value = trialCount
startpoint = n
Exit For
End If
Next n
Next i
End With
End Sub
It returns a "method _range of object _global falied" error on line: trialCount = Application.WorksheetFunction.CountA(Range("H" & CStr(startpoint) & ":" & "H" & CStr(nMinusOne)))
Module 3 is as follows:
Sub dotcountanalysis3()
Dim pressedCount As Long
Dim myCell As Range
Dim pressedRange As Range
'create trials array
Dim t(18) As Range
'set range for trialnumber (t)
Dim startpoint As Long
startpoint = 1
Dim lastrow As Long
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 1 To 18
For n = startpoint To lastrow
startpoint = 7
If Cells(n, 3).Value <> "Trial, " & CStr(i) Then
Set t(i - 1) = Range(Cells(startpoint, 3), Cells(n, 3))
n = n + 1
startpoint = n
Exit For
End If
Next n
Next i
'count presses in each trial
With Worksheets("full test")
For i = 0 To 17
pressedCount = Application.WorksheetFunction.CountA _
(.Range(.Cells(t(), "H"), .Cells(.Rows.Count, "H")))
If pressedCount = 0 Then Exit Sub
'make sure there are cells or else the next line will fail
Set pressedRange = .Columns("H").SpecialCells(xlCellTypeConstants)
For Each myCell In pressedRange.Cells
'only loop through the cells containing something
.Cells(myCell.Row, "T").Value = pressedCount
Next myCell
Next i
End With
End Sub
It returns a run-time "type mismatch" error on line: pressedCount = Application.WorksheetFunction.CountA _
(.Range(.Cells(t(), "H"), .Cells(.Rows.Count, "H")))
Edit: I have updated code in mod 3 and updated error.
When counting things I like to use a dictionary object, and arrays are faster than going row by row on the sheet.
This will count unique combinations of Block+Trial: to count only by trial you would just use k = d(r, COL_TRIAL)
Dim dBT As Object 'global dictionary
Sub dotcountanalysis()
'constants for column positions
Const COL_BLOCK As Long = 1
Const COL_TRIAL As Long = 2
Const COL_ACT As Long = 7
Dim rng As Range, lastrow As Long, sht As Worksheet
Dim d, r As Long, k, resBT()
Set sht = Worksheets("full test")
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
Set dBT = CreateObject("scripting.dictionary")
Set rng = sht.Range("B7:H" & lastrow)
d = rng.Value 'get the data into an array
ReDim resBT(1 To UBound(d), 1 To 1) 'resize the array which will
' be placed in ColT
'get unique combinations of Block and Trial and counts for each
For r = 1 To UBound(d, 1)
k = d(r, COL_BLOCK) & "|" & d(r, COL_TRIAL) 'create key
dBT(k) = dBT(k) + IIf(d(r, COL_ACT) <> "", 1, 0)
Next r
'populate array with appropriate counts for each row
For r = 1 To UBound(d, 1)
k = d(r, 1) & "|" & d(r, 2) 'create key
resBT(r, 1) = dBT(k) 'get the count
Next r
'place array to sheet
sht.Range("T7").Resize(UBound(resBT, 1), 1) = resBT
'show the counts in the Immediate pane (for debugging)
For Each k In dBT
Debug.Print k, dBT(k)
Next k
End Sub
I have the code below but I know it could be sped up by putting the data into an array which I don't know how. I'd appreciate any help.
Thanks In advance
For Each rngReportCell In rngReport
If rngReportCell = "" Then Exit For
If VBA.UCase(rngReportCell.Offset(0, 1).Value) = "X" Then
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = True
Else
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = False
End If
If rngRetrieveCell.Offset(0, 1).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 1).Value) _
= "'" & rngReportCell.Value
If rngReportCell.Offset(0, 2) <> "" And gRetrieveCell.Offset(0, 2).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 2).Value) _
= "'" & rngReportCell.Offset(0, 2).Value
TotalRows = range("Base_" & rngRetrieveCell).Rows.count
TotalCols = range("Base_" & rngRetrieveCell).Columns.count
'Copies values using range.value = range.value
range("A7").Offset(range("A7").CurrentRegion.Rows.count, 0).Resize(TotalRows, TotalCols).Value = _
wkbSOR.Sheets(rngRetrieveCell.Value).range("Base_" & rngRetrieveCell).Value
Next rngReportCell 'Store/Hyperion code
Maybe this will help you:
https://stackoverflow.com/questions/17859531/excel-vba-populate-array-with-range-from-specific-sheet
But essentially you will want to just import the range that you want into a 2-D array and iterate through as so (for example):
'Instantiate variant array
Dim arrValues() As Variant
arrValues = Sheet1.Range("A1:D10")
'Iterate through rows
For i = 1 To 10
'Iterate through columns
For j = 1 To 10
'your code here
Next
Next
Ubound can return the max index value of an array, but in a multidimensional array, how would I specify WHICH dimension I want the max index of?
For example
Dim arr(1 to 4, 1 to 3) As Variant
In this 4x3 array, how would I have Ubound return 4, and how would I have Ubound return 3?
ubound(arr, 1)
and
ubound(arr, 2)
You need to deal with the optional Rank parameter of UBound.
Dim arr(1 To 4, 1 To 3) As Variant
Debug.Print UBound(arr, 1) '◄ returns 4
Debug.Print UBound(arr, 2) '◄ returns 3
More at: UBound Function (Visual Basic)
[This is a late answer addressing the title of the question (since that is what people would encounter when searching) rather than the specifics of OP's question which has already been answered adequately]
Ubound is a bit fragile in that it provides no way to know how many dimensions an array has. You can use error trapping to determine the full layout of an array. The following returns a collection of arrays, one for each dimension. The count property can be used to determine the number of dimensions and their lower and upper bounds can be extracted as needed:
Function Bounds(A As Variant) As Collection
Dim C As New Collection
Dim v As Variant, i As Long
On Error GoTo exit_function
i = 1
Do While True
v = Array(LBound(A, i), UBound(A, i))
C.Add v
i = i + 1
Loop
exit_function:
Set Bounds = C
End Function
Used like this:
Sub test()
Dim i As Long
Dim A(1 To 10, 1 To 5, 4 To 10) As Integer
Dim B(1 To 5) As Variant
Dim C As Variant
Dim sizes As Collection
Set sizes = Bounds(A)
Debug.Print "A has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(B)
Debug.Print vbCrLf & "B has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(C)
Debug.Print vbCrLf & "C has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
End Sub
Output:
A has 3 dimensions:
1 to 10
1 to 5
4 to 10
B has 1 dimensions:
1 to 5
C has 0 dimensions:
UBound(myArray, 1) returns the number of rows in 2d array
UBound(myArray, 2) returns the number of columns in 2d array
However, let's go 1 step further and assume that you need the last row and last column of range, that has been written as a 2d array. That row (or column) should be converted to a 1d array. E.g. if our 2d array looks like this:
Then running the code below, will give you 2 1D arrays, that are the last column and last row:
Sub PrintMultidimensionalArrayExample()
Dim myRange As Range: Set myRange = Range("a1").CurrentRegion
Dim myArray As Variant: myArray = myRange
Dim lastRowArray As Variant: lastRowArray = GetRowFromMdArray(myArray, UBound(myArray, 1))
Dim lastColumnArray As Variant
lastColumnArray = GetColumnFromMdArray(myArray, UBound(myArray, 2))
End Sub
Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant
'returning a column from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 1)
ReDim result(size)
For i = LBound(myArray, 1) To UBound(myArray, 1)
result(i) = myArray(i, myCol)
Next
GetColumnFromMdArray = result
End Function
Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant
'returning a row from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 2)
ReDim result(size)
For i = LBound(myArray, 2) To UBound(myArray, 2)
result(i) = myArray(myRow, i)
Next
GetRowFromMdArray = result
End Function
In addition to the already excellent answers, also consider this function to retrieve both the number of dimensions and their bounds, which is similar to John's answer, but works and looks a little differently:
Function sizeOfArray(arr As Variant) As String
Dim str As String
Dim numDim As Integer
numDim = NumberOfArrayDimensions(arr)
str = "Array"
For i = 1 To numDim
str = str & "(" & LBound(arr, i) & " To " & UBound(arr, i)
If Not i = numDim Then
str = str & ", "
Else
str = str & ")"
End If
Next i
sizeOfArray = str
End Function
Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
' http://www.cpearson.com/excel/vbaarrays.htm
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Example usage:
Sub arrSizeTester()
Dim arr(1 To 2, 3 To 22, 2 To 9, 12 To 18) As Variant
Debug.Print sizeOfArray(arr())
End Sub
And its output:
Array(1 To 2, 3 To 22, 2 To 9, 12 To 18)
Looping D3 ways;
Sub SearchArray()
Dim arr(3, 2) As Variant
arr(0, 0) = "A"
arr(0, 1) = "1"
arr(0, 2) = "w"
arr(1, 0) = "B"
arr(1, 1) = "2"
arr(1, 2) = "x"
arr(2, 0) = "C"
arr(2, 1) = "3"
arr(2, 2) = "y"
arr(3, 0) = "D"
arr(3, 1) = "4"
arr(3, 2) = "z"
Debug.Print "Loop Dimension 1"
For i = 0 To UBound(arr, 1)
Debug.Print "arr(" & i & ", 0) is " & arr(i, 0)
Next i
Debug.Print ""
Debug.Print "Loop Dimension 2"
For j = 0 To UBound(arr, 2)
Debug.Print "arr(0, " & j & ") is " & arr(0, j)
Next j
Debug.Print ""
Debug.Print "Loop Dimension 1 and 2"
For i = 0 To UBound(arr, 1)
For j = 0 To UBound(arr, 2)
Debug.Print "arr(" & i & ", " & j & ") is " & arr(i, j)
Next j
Next i
Debug.Print ""
End Sub