StackOverflow,
The below subroutine is intended to:
take a dictionary (ByRef), with value types = double, OR
take a dictionary of dictionaries (ByRef), with sub-dictionary value types = double, and
apply the calculation "ApproximateGeometricReturn" to each value within the dictionary.
While the code successfully runs, it fails to apply the calculation to the each value in the dictionary passed as an argument (ByRef).
Please suggest where I may have gone wrong. I have also attempted to write this as a recursive subroutine without success.
Private Sub ApproxiamteGeometricReturns(ByRef LogReturnDictionary As Variant)
For Each Item In LogReturnDictionary.Items
If TypeName(Item) = "Double()" Then
For Each i In Item
i = ApproximateGeometricReturn(i)
Next
Else
Item = ApproximateGeometricReturn(Item)
End If
Next
End Sub
Any suggestions will be warmly received. Thanks.
Private Sub ApproxiamteGeometricReturns(ByRef LogReturnDictionary As Variant)
For Each keyName In LogReturnDictionary.Keys
If TypeName(LogReturnDictionary(keyName)) = "Double()" Then
Dim arr As Variant: arr = LogReturnDictionary(keyName)
Dim index As Integer
For index = LBound(arr) To UBound(arr)
arr(index) = ApproximateGeometricReturn(arr(index))
Next
LogReturnDictionary(keyName) = arr
Else
LogReturnDictionary(keyName) = ApproximateGeometricReturn(LogReturnDictionary(keyName))
End If
Next
End Sub
Related
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 am writing vba code that will search all listbox items against a entire column in a sheet.
If listbox item not found in Excel sheet column, i want to delete the item from list. I tried few codes, its showing some error as "Could not get list property, Invalid property array index". Below is my code i am using currently.
Private Sub CommandButton1_Click()
Dim itemExistResults As Boolean
Dim myarray()
Dim intItem As Long
myarray = Application.Transpose(Sheet1.Range("a2:a1000"))
For intItem = 0 To ListBox1.ListCount - 1
If IsInArray(ListBox1.List(intItem), myarray) Then
Else
ListBox1.RemoveItem intItem
End If
Next
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = UBound(Filter(arr, stringToBeFound)) > -1
End Function
Any idea where i am wrong in this code.
You should iterate from the last item of list to the first, because removing items changes their indexation.
Try to change your loop like that:
For intItem = ListBox1.ListCount - 1 To 0 Step -1
If IsInArray(ListBox1.List(intItem), myarray) Then
Else
ListBox1.RemoveItem intItem
End If
Next
I have a tip for you connected with your task, but not exactly with the error described in question.
For this type of task you should use object of Dictionary type instead of iterating through array - it would be much more effective.
I have modified your code to use dictionary. Check it and compare the time each of those solutions need to complete this task - the one with dictionary should be much faster. If you have any questions regarding this code, let me know in comments.
Private Sub CommandButton1_Click()
Dim myArray As Variant
Dim intItem As Long
Dim dict As Object
Dim i As Long
Dim value As Variant
'--- [Loading data into dictionary] ------------------------------------
Set dict = VBA.CreateObject("Scripting.Dictionary")
myArray = Sheet1.Range("A2:A1000")
'Iterate through all the items in array and load them into dictionary.
For i = LBound(myArray) To UBound(myArray)
value = myArray(i, 1)
If Not IsEmpty(value) Then
If Not dict.exists(value) Then
Call dict.Add(value, 0)
End If
End If
Next i
'-----------------------------------------------------------------------
'--- [Comparing ListBox with dictionary] -------------------------------
With ListBox1
For intItem = .ListCount - 1 To 0 Step -1
value = .List(intItem)
If Not dict.exists(value) Then
.RemoveItem intItem
End If
Next
End With
'-----------------------------------------------------------------------
End Sub
Trying to search on a ListBox. Specifically, I want to look at an array of items from the Cell, and for each one that matches an entry in the ListBox, I want it to select that List.
I copy-pasted some code that was supposed to let me find a string, but it keeps telling me:
Compile Error: Method or Data Member not found.
Any suggestions?
Relevant Code:
Public local_Target As Range
' local_Target is assigned in the sheet function to pass it here
Private Sub Network_ListBox_Enter()
' Get data in cell (if any)
Dim current_data As String
Dim entries() As String
current_data = local_Target.Value
If current_data = "" Then
Exit Sub
Else
entries = Split(current_data, vbNewLine)
End If
For Each Item In entries
FindMyString Item
Next Item
End Sub
Private Sub UserForm_Terminate()
Dim index As Integer
Dim result As String
' Iterate through the listbox and create the result, then assign to
' Target.value
For index = 0 To Network_ListBox.ListCount - 1
If Network_ListBox.Selected(index) Then
' stuff
If result = "" Then
result = Network_ListBox.List(index)
' ElseIf index = Network_ListBox.ListCount - 1 Then
' result = result + Network_ListBox.List(index)
Else
result = result + vbNewLine + Network_ListBox.List(index)
End If
End If
Next index
local_Target.Value = result
End Sub
Sub FindMyString(ByVal searchString As String)
' Ensure we have a proper string to search for.
If searchString <> "" Then
' Find the item in the list and store the index to the item.
Dim index As Integer
index = Me.Network_ListBox.FindString(searchString)
' Determine if a valid index is returned. Select the item if it is valid.
If index <> -1 Then
Network_ListBox.SetSelected index, True
'Else
' MessageBox.Show ("The search string did not match any items in the ListBox")
End If
End If
End Sub
I checked Intellisense and I don't think that Method is supported in VBA. Other documentations I've found refers to .Net Framework only as well. So maybe, it is not really supported in VBA, but regardless, you can create a function to do just that. Something like below.
Private Function SearchString(mysearch As String, mylist As Variant) As Long
Dim itm As Variant, idx As Long: idx = 0
If IsArray(mylist) Then
For Each itm In mylist
If mysearch = itm Then
SearchString = idx: Exit Function
End If
idx = idx + 1
Next
End If
SearchString = -1
End Function
And you can use it like this:
Private Sub CommandButton1_Click()
Dim i As Long
'do the search
i = SearchString("WhatImSearching", Me.ListBox1.List)
'select the item that match your search
If i <> -1 Then Me.ListBox1.Selected(i) = True
End Sub
I'm not saying that the function I created above is the most efficient way.
That is just an example to give you an idea for a workaround. HTH.
Important: This works in single column ListBox which have a 1D array list. If you need to work on multi-column ListBox, you'll have to tweak the function a little.
I am trying to pass a blank array to a function that will manipulate the array dependent on certain scenarios. I don't know where I am going wrong with this but I am getting the following error Type mismatch. Below shows how I am creating the blank array:
Dim testArray(0 to 10) as string
Dim ABredu() As String
ABredu = Equipment(testArray)
Below shows the function that I have written to populate the array
Function Equipment(Test() As String)
If standYes = True And .ComboBox2.ListIndex = 0 Then
ReDim ABredu(1 To 3)
ABredu(1) = "Pen"
ABredu(2) = "Ruler"
ABredu(3) = "Monitor"
Else
ReDim ABredu(1 To 3)
ABredu(1) = "17-P2"
ABredu(2) = "17-L73"
ABredu(3) = "16-ENR"
End If
End sub
If someone could help me or give a push in the right direction it would be greatly appreciated!
Pass the array by reference as a variant.
Function Equipment(ByRef Test As Variant)
If standYes = True And .ComboBox2.ListIndex = 0 Then
ReDim Test(1 To 3)
Test(1) = "Pen"
Test(2) = "Ruler"
Test(3) = "Monitor"
Else
ReDim Test(1 To 3)
Test(1) = "17-P2"
Test(2) = "17-L73"
Test(3) = "16-ENR"
End If
End sub
Slightly different approach using variant arrays.
Sub Some_Macro()
Dim ABredu As Variant, i As Long
ABredu = Equipment(True, 0)
For i = LBound(ABredu) To UBound(ABredu)
Debug.Print ABredu(i)
Next i
ABredu = Equipment(False, 0)
For i = LBound(ABredu) To UBound(ABredu)
Debug.Print ABredu(i)
Next i
End Sub
Public Function Equipment(standYes As Boolean, cdLI As Long)
Dim vEQUIP As Variant
If standYes And cdLI = 0 Then
vEQUIP = Array("Pen", "Ruler", "Monitor")
Else
vEQUIP = Array("17-P2", "17-L73", "16-ENR")
End If
Equipment = vEQUIP
End Function
There are several ways to accomplish what you are looking for. Pick the one that makes the most sense to you.
Okay, so I'm going to make a couple of assumptions about your expected logic here, since the code in your question is a bit nonsensical.
You're trying (I think) to:
Create an array of strings called ABredu
Use a function or subroutine to populate that array based on some conditions
With that in mind, you can create the following sub
Sub PopulateEquipment(EquipArr() As String)
ReDim EquipArr(1 To 3)
If <condition> Then '<~~ Insert your own conditions here
EquipArr(1) = "Value 1"
EquipArr(2) = "Value 2"
EquipArr(3) = "Value 3"
Else
EquipArr(1) = "AltVal 1"
EquipArr(2) = "AltVal 2"
EquipArr(3) = "AltVal 3"
End If
End Sub
Then to populate your array using this, you need only Dim it and then call the subroutine, passing the variable as an argument.
Dim ABredu() As String
Call PopulateEquipment(ABredu)
Even simpler, use an ArrayList.
Public arList As Object
Sub PartOne()
Set arList = CreateObject("System.Collections.ArrayList")
Call Equipment
End Sub
Private Sub Equipment() '// No Need to pass argument as arList is of Public scope.
With arList
If standYes And Me.ComboBox2.ListIndex = 0 Then
.Add "Pen"
.Add "Ruler"
.Add "Monitor"
Else
.Add "17-P2"
.Add "17-L73"
.Add "16-ENR"
End If
End With
End Sub
I searched the website but was not succesfful and tried doing some research on this but facing with " Type Mismatch" error.
I declared an array as integer type but the FILTER function seems to work only with STRING's. Can you please let me know how I can use the FILTER function for integers?
If UBound(Filter(CntArr(), count)) > 0 Then
msgbox "found"
End If
as i understand you need to know if specified count present in array. You can use for loop for it:
Dim found as Boolean
found = False
For i = 0 To UBound (CntArr())
If CntArr(i) = count Then
found = True
Exit For
End If
Next i
If found Then msgbox "found" End If
Below I have created IsIntegerInArray() function that returns boolean. Follow the two Subs for an example of integer array declaration. Declaring array as Integer should also prevent some unnecessary bugs caused by implicit data conversion.
Sub test_int_array()
Dim a() As Integer
ReDim a(3)
a(0) = 2
a(1) = 15
a(2) = 16
a(3) = 8
''' expected result: 1 row for each integer in the array
Call test_printing_array(a)
End Sub
Sub test_printing_array(arr() As Integer)
Dim i As Integer
For i = 1 To 20
If IsIntegerInArray(i, arr) Then
Debug.Print i & " is in array."
End If
Next i
End Sub
Function IsIntegerInArray(integerToBeFound As Integer, arr() As Integer) As Boolean
Dim i As Integer
''' incorrect approach:
''' IsIntegerInArray = (UBound(Filter(arr, integerToBeFound)) > -1) ' this approach searches for string, e.g. it matches "1" in "12"
''' correct approach:
IsIntegerInArray = False
For i = LBound(arr) To UBound(arr)
If arr(i) = integerToBeFound Then
IsIntegerInArray = True
Exit Function
End If
Next i
End Function