I have two variables defined like this:
Per_Mnd = Worksheets("Sheet1").Range("G2:G8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:G8").Value
Obviously both Per_Mnd and Per_Mnd2 have 7 rows and 1 column. Now I want to sum them up element by element, getting another 7×1 array. How do I do it?
And what is they are defined by matrix
Per_Mnd = Worksheets("Sheet1").Range("G2:H8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:H8").Value
How can I quickly sum them up element by element?
thanks!
You can simply evaluate an INDEX formula to return the array:
Sub Test()
Dim oarr As Variant
Dim Per_Mnd As Variant
Dim Per_Mnd2 As Variant
Per_Mnd = Worksheets("Sheet1").Range("G2:G8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:G8").Value
With Application
oarr = .Transpose(.Evaluate("INDEX({" & Join(.Transpose(Per_Mnd), ",") & "}+{" & Join(.Transpose(Per_Mnd2), ",") & "},)"))
End With
Debug.Print oarr(3, 1)
End Sub
Note: this only works with single column arrays of the same size.
If you want to sum a matrix, the VBA way is WorksheetFunction.SumProduct
Take the example below, returning 60 -> 1*10+2*10+3*10
Public Sub TestMe()
Dim el1 As Variant
Dim el2 As Variant
Dim res As Variant
el1 = Application.Transpose(Range("A1:A3"))
el2 = Application.Transpose(Range("B1:B3"))
Debug.Print WorksheetFunction.SumProduct(el1, el2)
ReDim res(1 To UBound(el1))
Dim cnt As Long
For cnt = LBound(el1) To UBound(el1)
res(cnt) = el1(cnt) + el2(cnt)
Next cnt
End Sub
The idea of Application.Transpose() is to present the Range() as a one dimensional array. Once we do so, we introduce res(1 to UBound(el1) where we write the product per element. Or you can even do the SumArray as a function, returning the new array:
Public Function SumArray(arr1 As Variant, arr2 As Variant) As Variant
ReDim res(1 To UBound(arr1))
Dim cnt As Long
For cnt = LBound(arr1) To UBound(arr1)
res(cnt) = arr1(cnt) + arr2(cnt)
Next cnt
SumArray = res
End Function
Related
I am wondering if VBA can return more than 1 array in a function. I have created a function called 'getStats()' and i would like to return 2 arrays named 'returnVal' and 'a' as shown below. I have tried the methods below but i only get back the value for array 'a' which is 10. It does'nt give me the array for 'returnVal'. Is there any way to do that? Pls help. I tried doing this: "getStats = returnVal & a " but an error occured as type mismatch
Sub mysub()
Dim i As Integer
Dim myArray() As Integer
myArray() = getStats() 'calling for function
MsgBox myArray(0)
MsgBox myArray(1)
MsgBox myArray(2)
End Sub
Function getStats() As Integer()
Dim returnVal(1 To 2) As Integer
Dim a(0) As Integer
returnVal(1) = 7
returnVal(2) = 8
a(0) = 5 + 5
getStats = returnVal 'returning value
getStats = a 'returning value
End Function
A Function procedure can return one single result.
You can make that result a Variant and return an array of arrays or a custom object that encapsulates two arrays, but no matter what you do the function returns one value of the type you specify as its return type in its signature.
Or you can take ByRef parameters - this should work (untested):
Public Sub GimmeTwoArrays(ByRef outArray1 As Variant, ByRef outArray2 As Variant)
ReDim outArray1(1 To 10)
ReDim outArray2(1 To 10)
Dim i As Long
For i = 1 To 10
outArray1(i) = i
outArray2(i) = Chr$(64 + i)
Next
End Sub
The caller only needs to pass the variant pointers, doesn't matter if you initialize them or not:
Dim values1 As Variant
Dim values2 As Variant
GimmeTwoArrays values1, values2
Debug.Print values1(1), values2(1)
You don't have to declare them As Variant, but wrapping your arrays in a Variant generally makes them easier to pass around and work with.
Return function results as ParamArray contents
In addition to Mathieu's valid answer referring to an array of arrays (or jagged array), I demonstrate a way to get the function results as ParamArray contents passed as empty array arguments. The function result assigned to arr has the possible advantage to dispose of several ways to address the individual or entire array contents:
get the whole set (e.g. array name arr) conform to ParamArray structure
get the sub sets directly, even by the original array names (here a and b)
Sub ExampleCall()
'[0] declare empty arrays and assign array to function results via ParamArray argument
Dim arr, a(1 To 10), b(1 To 10)
arr = GetBoth(a, b) ' << function GetBoth()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Two options to display results:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] get the whole set conform to ParamArray structure
' shows: arr(0) ~> 1,2,3,4,5,6,7,8,9,10 arr(1) ~> A,B,C,D,E,F,G,H,I,J
Debug.Print "arr(0) ~> " & Join(arr(0), ","), _
"arr(1) ~> " & Join(arr(1), ",")
'[2] get the sub sets directly, even by the original array names
' shows: a ~> 1|2|3|4|5|6|7|8|9|10 b ~> A|B|C|D|E|F|G|H|I|J
Debug.Print "a ~> " & Join(a, "|"), _
"b ~> " & Join(b, "|")
'[ad) 1/2] get individual values, e.g. the first item of the second array
' note that sub sets a and b got a 1-base declaration here,
' whereas the array of the subset arrays remains 0-based
Debug.Print "arr(1)(2) = " & arr(1)(2) ' // shows: arr(1)(2) = B
Debug.Print "b(2) = " & b(2) ' // shows: b(2) = B
End Sub
Function GetBoth() via ParamArray arguments
Function GetBoth(ParamArray arr()) As Variant
Dim i As Long
For i = 1 To 10
arr(0)(i) = i
arr(1)(i) = Chr$(64 + i)
Next
GetBoth = arr
End Function
Inspired by Mathieu and T.M, this function creates an arbitrary number of variables, and deals out a deck of cards.
Sub PlayHand()
Dim Huey(0 To 4), Dewey(0 To 4), Louie(0 To 4)
DealCards Huey, Dewey, Louie
Dim Charlotte(0 To 6), Anne(0 To 6), Elizabeth(0 To 6), Maria(0 To 6)
Combined = DealCards(Charlotte, Anne, Elizabeth, Maria)
End Sub
Function DealCards(ParamArray Players())
'Create deck of cards
Set cardCollection = New Collection
For Each suit In Array("H", "C", "S", "D")
For Each rank In Array(2, 3, 4, 5, 6, 7, 8, 9, 10, "J", "Q", "K", "A")
cardCollection.Add suit & "_" & Rank
Next
Next
'Deal out the cards to each player
For i = 0 To UBound(Players)
For j = 0 To UBound(Players(i))
randomCard = Round(Rnd() * cardCollection.Count + 0.5, 0)
Players(i)(j) = cardCollection(randomCard)
cardCollection.Remove randomCard
Next
Next
DealHand = Players
End Function
Merge Two Long Arrays
Option Explicit
Sub mysub()
Dim i As Long
Dim myArray() As Long
myArray() = getStats() 'calling for function
For i = LBound(myArray) To UBound(myArray)
Debug.Print myArray(i)
' MsgBox myArray(i)
Next i
End Sub
Function getStats() As Long()
Dim returnVal(1 To 2) As Long
Dim a(0) As Long
returnVal(1) = 7
returnVal(2) = 8
a(0) = 5 + 5
getStats = mergeTwoLongArrays(returnVal, a)
End Function
Function mergeTwoLongArrays(Array1, Array2, Optional Base As Long = 0)
Dim arr() As Long
Dim NoE As Long
Dim countNew As Long
NoE = UBound(Array1) - LBound(Array1) + UBound(Array2) - UBound(Array2) + 2
ReDim arr(Base To NoE - Base - 1)
countNew = LBound(arr)
For NoE = LBound(Array1) To UBound(Array1)
arr(countNew) = Array1(NoE)
countNew = countNew + 1
Next NoE
For NoE = LBound(Array2) To UBound(Array2)
arr(countNew) = Array2(NoE)
countNew = countNew + 1
Next NoE
mergeTwoLongArrays = arr
End Function
I have a standard user defined function that concationates all the unique values. What I am trying to do is to perform this function on a range that satisfies a condition.
Function ConcatUniq(xRg As Range, xChar As String) As String
'updateby Extendoffice 20151228
Dim xCell As Range
Dim xDic As Object
Set xDic = CreateObject("Scripting.Dictionary")
For Each xCell In xRg
xDic(xCell.Value) = Empty
Next
ConcatUniq = Join$(xDic.Keys, xChar)
Set xDic = Nothing
End Function
Lets make an example:
If we have the following data:
A1:A5 = {1,2,2,4,1}
B1:B5 = {"group1", "group1","group1", "group2", "group2"}
C1 = "group1"
Now I want to find the unique values using the ConcatUniq function for all numbers that are in group1. Usually, if I want to perform another function for example the median I would do the following:
=MEDIAN(IF(B1:B5=C1,A1:A5))
Activate it using cntrl shift enter which gives 2 (create an array function from it).
For some reasons this does not work in combination with a user defined function.
=ConcatUniq(IF(B1:B5=C1,A1:A5)," ")
Desired result:
1 2
Does someone know how I could fix this problem?
You need to use ParamArray to accommodate array returned from Excel's array formula. As ParamArray should always be the last one, so your method signature will change.
This will work with =ConcatUniq(" ",IF(B1:B5=C1,A1:A5)) on CTRL + SHIFT + ENTER
Public Function ConcatUniq(xChar As String, ParamArray args())
Dim xDic As Object
Dim xVal
Set xDic = CreateObject("Scripting.Dictionary")
For Each xVal In args(0)
If Not Not xVal Then
xDic(xVal) = Empty
End If
Next
ConcatUniq = Join$(xDic.Keys, xChar)
End Function
Perhaps something like this:
Public Function ConcatUniq(ByVal rangeOrArray As Variant, ByVal xChar As String) As String
Dim generalArray As Variant
If IsArray(rangeOrArray) Then
'operate on it as if was an array
generalArray = rangeOrArray
Else
If TypeName(rangeOrArray) = "Range" Then
'operate on it as if was a Range
If rangeOrArray.Cells.Count > 1 Then
generalArray = rangeOrArray.Value
Else
generalArray = Array(rangeOrArray.Value)
End If
Else
'Try to process as if it was a derivative of a value of a single cell range.....
generalArray = Array(rangeOrArray)
End If
End If
Dim xDic As Object
Set xDic = CreateObject("Scripting.Dictionary")
Dim xCell As Variant
For Each xCell In generalArray
If xCell <> False Then xDic(xCell) = Empty ' EDIT - HACKY....
Next
ConcatUniq = Join$(xDic.Keys, xChar)
End Function
You can see that that whole block of if-elses can be factored out to be a separate function to transform worksheet input to a unified form for operating on values of a worksheet.
The easiest solution would probably be to introduce an additional function. This function would take care of the condition and would generate an array consisting only of data fulfilling the condition.
Try something like this:
function condition_check(data1() as integer, data2() as string, condition_value as string) as integer
number_of_elements = Ubound(data1)
j = 0
for i = 0 to number_of_elements
if data2(i) = condition_value then
condition_check(j) = data1(i)
j = j+1
end if
next i
end function
I have an array that looks like this:
Dim values(1 To 3) As String
values(1) = Sheets("risk_cat_2").Cells(4, 6).Value
values(2) = Sheets("risk_cat_2").Cells(5, 6).Value
values(3) = Sheets("risk_cat_2").Cells(6, 6).Value
What I would like to do now is get the maximum value from all the values in string. Is there an easy way in VBA to fetch the max value from an array?
Is there an easy way in VBA to fetch the max value from an array?
Yes - if the values are numeric. You can use WorksheetFunction.Max in VBA.
For strings - this won't work.
Sub Test2()
Dim arr(1 To 3) As Long
arr(1) = 100
arr(2) = 200
arr(3) = 300
Debug.Print WorksheetFunction.Max(arr)
End Sub
Simple loop would do the trick
Dim Count As Integer, maxVal As Long
maxVal = Values(1)
For Count = 2 to UBound(values)
If Values(Count) > maxVal Then
maxVal = Values(Count)
End If
Next Count
The easiest way to retrieve the maximum (I can think of) is iterating through the array and comparing the values. The following two functions do just that:
Option Explicit
Public Sub InitialValues()
Dim strValues(1 To 3) As String
strValues(1) = 3
strValues(2) = "af"
strValues(3) = 6
Debug.Print GetMaxString(strValues)
Debug.Print GetMaxNumber(strValues)
End Sub
Public Function GetMaxString(ByRef strValues() As String) As String
Dim i As Long
For i = LBound(strValues) To UBound(strValues)
If GetMaxString < strValues(i) Then GetMaxString = strValues(i)
Next i
End Function
Public Function GetMaxNumber(ByRef strValues() As String) As Double
Dim i As Long
For i = LBound(strValues) To UBound(strValues)
If IsNumeric(strValues(i)) Then
If CDbl(strValues(i)) > GetMaxNumber Then GetMaxNumber = CDbl(strValues(i))
End If
Next i
End Function
Note, that each time a string (text) array is passed to the function. Yet, one function is comparing strings (text) while the other is comparing numbers. The outcome is quite different!
The first function (comparing text) will return (with the above sample data) af as the maximum, while the second function will only consider numbers and therefore returns 6 as the maximum.
Solution for Collection.
Sub testColl()
Dim tempColl As Collection
Set tempColl = New Collection
tempColl.Add 57
tempColl.Add 10
tempColl.Add 15
tempColl.Add 100
tempColl.Add 8
Debug.Print largestNumber(tempColl, 2) 'prints 57
End Sub
Function largestNumber(inputColl As Collection, indexMax As Long)
Dim element As Variant
Dim result As Double
result = 0
Dim i As Long
Dim previousMax As Double
For i = 1 To indexMax
For Each element In inputColl
If i > 1 And element > result And element < previousMax Then
result = element
ElseIf i = 1 And element > result Then
result = element
End If
Next
previousMax = result
result = 0
Next
largestNumber = previousMax
End Function
I've been writing a macro for Solidworks in VBA, and at one point I'd like to rearrange the sheets in a drawing in the following way--if any of the sheets are named "CUT", bring that sheet to the front. Solidworks API provides a way to rearrange the sheets, but it requires an array of sheet names sorted into the correct order--fair enough. The way to get the sheet names looks to be this method.
So, I tried to write a small function to rearrange the sheets in the way I want. The function call I'm trying to use and the function are shown here
Function Call
Dim swApp As SldWorks.SldWorks
Dim swDrawing As SldWorks.DrawingDoc
Dim bool As Boolean
Set swApp = Application.SldWorks
Set swDrawing = swApp.ActiveDoc
.
.
.
bool = swDrawing.ReorderSheets(bringToFront(swDrawing.GetSheetNames, "CUT"))
Function Definition
Private Function bringToFront(inputArray() As String, _
stringToFind As String) As String()
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
Dim outputArray() As String
first = LBound(inputArray)
last = UBound(inputArray)
ReDim outputArray(first to last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
outputArray(j + 1) = inputArray(j)
Next j
For j = (i + 1) To last
outputArray(j) = inputArray(j)
Next j
outputArray(first) = stringToFind
End If
Next i
bringToFront = outputArray
End Function
The error I get is "Type mismatch: array or user defined type expected" on the function call line. I've done quite a bit of searching and I think what I'm messing up has to do with static vs dynamic arrays, but I haven't quite been able to get to the solution on my own.
Besides the corrections suggested in the comments, what is happening is that at the lines
bringToFront(j + 1) = inputArray(j)
and
bringToFront(first) = stringToFind
the compiler thinks you are trying to call recursively the function bringToFront. That is why it complains about the number of parameters in the error message. To fix this, just create another array as local array variable, with a different name, let us name it "ret", fill it appropriately, and assign it at the end before returning.
EDIT: Also, it is better to declare the arrays as Variant types to avoid interoperability problems between VB6 and .Net . This was the final issue
Private Function bringToFront(inputArray As Variant, _
stringToFind As String) As Variant
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
first = LBound(inputArray)
last = UBound(inputArray)
Dim ret() As String
ReDim ret(first To last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
ret(j + 1) = inputArray(j)
Next j
ret(first) = stringToFind
End If
Next i
bringToFront = ret
End Function
I have written below Code in SSRS Report and calling it from expression as =Code.convertCode(Parameters!ProcessingStatus.Value,"Reject,Fail")).Value , but on previewing report I am getting the error : "Number of indices is less than the number of dimensions of the indexed array"
Public Function convertCode(ParamValues As String, findString As String) As String()
Dim SrcArray() As String
Dim FndArray() As String
Dim DstArray() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
SrcArray() = Split(ParamValues, ",")
FndArray() = Split(FindString,",")
For k = LBound(FndArray) To UBound(FndArray)
For i = LBound(SrcArray) To UBound(SrcArray)
If (InStr(SrcArray(i), FndArray(k)) > 0) Then
ReDim Preserve DstArray(j) As String
DstArray(j) = SrcArray(i)
j = j + 1
End If
Next i
Next k
arr = DstArray
End Function
At the end of your function you have
arr = DstArray
which should be
convertCode = DstArray
Not sure if that's already the problem.
Note: Option Explicit would prevent this error.
I think the problem is that you're not declaring the first dimension in your arrays.
Dim SrcArray() As String
Dim FndArray() As String
Dim DstArray() As String
Should be:
Dim SrcArray(10) As String
Dim FndArray(10) As String
Dim DstArray(10) As String
Or whatever the number of the Array you'll need.
The error message indicates that the number of indices you have (none) is less that what you need (variables I, k, j).