Excel VBA: MoviesByGenre Function - vba

I am trying to write an Excel VBA function that will do two things. First, it will determine the number of movies in each genre and print it to the immediate window using the printMovieData function I have written. Secondly, it will return the genre that has the most number of movies using the FindMax function I have written. I have provided my codes for printMovieData, FindMax, and what I have so far for MoviesByGenre, however, I am not sure what I am doing wrong and am looking for help to get the function working. Currently, Excel is returning the #VALUE! error.
printMovieData:
Function printMovieData(title As String, arrayTopic, arrayOther)
printMovieData = ""
For i = 1 To UBound(arrayTopic)
Debug.Print arrayTopic(i) & " : " & arrayOther(i)
Next i
End Function
FindMax:
Function FindMax(valueArray, nameArray) As String
Dim i As Integer
Dim maxValue As Variant
maxValue = 0
For i = 1 To UBound(valueArray)
If valueArray(i) >= maxValue Then
maxValue = valueArray(i)
FindMax = nameArray(i)
End If
Next i
End Function
MoviesByGenre:
Function MoviesByGenre(genreRng As Range) As String
Dim i As Integer
Dim genreArray(1 To 4) As String
Dim countArray
genreArray(1) = Action
genreArray(2) = Comedy
genreArray(3) = Drama
genreArray(4) = Musical
For i = 1 To UBound(genreArray)
For j = 1 To genreRng.Count
If genreRng.Cells(j) = genreArray(i) Then
countArray(i) = countArray(i) + 1
End If
Next j
Next i
MoviesByGenre = printMovieData("Movies by Genre", genreArray, countArray)
MoviesByGenre = FindMax(countArray, genreArray)
End Function

TBH there are quite a lot of reasons why I wouldn't expect your code to work.
There are some assumptions made such as how you use genreRng.Count. This is assuming data to count is either one row or one column.
The following assumes that genreRng.Cells.Count, Ubound(genreArray) and UBound(countArray) are all the same. You don't ensure this.
There are missing variable declarations, no use of Option Explicit and a number of other things.
Overarching though, is that I think you want a different object to handle your count. This is where Collection and Scripting Dictionaries are very useful.
You can have the key as the genre and the count is held in the associated value. If the key already exists, i.e. a repeat genre, just add one to the existing count.
With that in mind, a starting point, might be something like (sorry, no error handling added):
Option Explicit
Public Sub test()
Dim genreCount As Object
Set genreCount = CreateObject("Scripting.Dictionary")
Set genreCount = MoviesByGenre(ActiveSheet.Range("A1:A3"), genreCount)
printMovieData "Movies by genre", genreCount
FindMax genreCount
End Sub
Public Function MoviesByGenre(ByRef genreRng As Range, ByVal genreCount As Object) As Object
Dim j As Long
For j = 1 To genreRng.Count 'assumes 1 column/row
Dim currentGenre As String
currentGenre = genreRng.Cells(j, 1)
If Not genreCount.Exists(currentGenre) Then
genreCount.Add currentGenre, 1
Else
genreCount(currentGenre) = genreCount(currentGenre) + 1
End If
Next j
Set MoviesByGenre = genreCount
End Function
Public Function printMovieData(ByVal title As String, ByVal genreCount As Object)
Dim key As Variant
Debug.Print title & vbCrLf 'put to next line
For Each key In genreCount.keys
Debug.Print key & " : " & genreCount(key)
Next key
End Function
Public Function FindMax(ByVal genreCount As Object) As String
Dim maxValue As Long
Dim maxGenre As String
Dim key As Variant
For Each key In genreCount.keys
If genreCount(key) > maxValue Then
maxValue = genreCount(key)
maxGenre = key
End If
Next key
Debug.Print vbNewLine & "Max genre is " & maxGenre & " with " & maxValue
End Function
Input and output:
Input:
Output:

Related

Report's textbox function call from ControlSource not firing

Firstly, here's a pic on my report in design mode:
The underlying query for the report returns values like so:
Allen Nelli 3:A,5:B,7:A,8:A, etc.
Breton Micheline 1:A,3:A,5:B,7:A, etc
Caporale Jody 1:A,3:A,5:B,7:A, etc
I had to use a subquery to get the third field which concatenates the number : letter combinations. These values actually represent day of month and designation to a particular shift in a schedule. So basically, for a given month, each individual works the designated shift indicated by the day value.
The intention is to call a user defined public function named PopulateTextboxes(Value as String) to be called from the first textbox in the report from the textbox's ControlSource property. The third field in the query is actually named Expr1 and that is being passed as a parameter to the function. The function is designed to populate all the textboxes with the appropriate letter designation: A or B or C or D, etc. The function itself is not being fired when I run the report.
The function is as follows:
Public Function PopulateTextboxes(Expr As String) As String
'Each element of Expr should be a number followed by a colon followed by a letter: 10:A,12:B,15:C, etc.
Dim shiftData() As String
Dim Data As Variant
Dim i As Integer
Dim j As Integer
Dim temp() As String
Dim txt As TextBox
Dim rpt As Report
Dim strCtrl As String
If Expr = "" Then Exit Function
If IsNull(Expr) Then Exit Function
shiftData = Split(Expr, ",")
If UBound(shiftData) > 0 Then
'Make a 2D array
ReDim Data(UBound(shiftData), 2)
'Load up 2D array
For i = 0 To UBound(shiftData) - 1
If shiftData(i) <> "" Then
temp = SplitElement(shiftData(i), ":")
Data(i, 0) = temp(0)
Data(i, 1) = temp(1)
End If
Next i
Set rpt = Reports.item("Multi_Locations_Part_1")
If UBound(days) = 0 Then
MsgBox "days array not populated"
Exit Function
End If
'Populate each Textbox in the Multi_Locations_Part_1 Report
For i = 1 To UBound(days)
strCtrl = "txtDesig_" & CStr(i)
Set txt = rpt.Controls.item(strCtrl)
For j = 0 To UBound(Data) - 1
If Data(j, 0) = days(i) Then
txt.Value = Data(j, 1) 'A,B,C,etc.
Exit For
End If
Next j
Next i
End If
PopulateTextboxes = Expr
End Function
Private Function SplitElement(Value As String, Delim As String) As String()
Dim result() As String
result = Split(Value, Delim)
SplitElement = result
End Function
Please advise.
The best way is to call your function from the Format event of the Detail section, so it will be called for each record.
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Call PopulateTextboxes(Me.Expr1)
End Sub
If PopulateTextboxes is in a separate module, I suggest to pass Me as additional parameter for the report, so you don't have to hardcode the report name.
Also note that you need the Set keyword when assigning object variables, e.g.
Set txt = rpt.Controls.item("txtDesig_" & CStr(i))

Why ListBox doesn't have a FindString method in Excel-VBA?

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.

VBA comparing multiple variables

There any way to compare multiple variables in VBA? For example:
Dim x As Integer
Dim y As Integer
Dim z As Integer
x = 99
y = 2
z = 3
I would like to return the smallest of the values.
I understand I could use select case x > y for all possible permutations but that seems unwieldy for more than 3 variables.
I have tried the worksheet function
solution = Application.WorksheetFunction.Min(x, y, z)
but that returns 2 and I would like it to return the variable name to be passed to another function.
many thanks,
Edit: My apologies if this was confusing, I am still a VBA novice. Here's my problem a little more generally:
I have a list of codes that correspond to names, many names per code. I want to loop through every name per code and count the number of instances that name appears on a list and choose the name with the LEAST occurrences. (could be 0 or could be the same as another name). obviously if there were 2 names it would be easy to do a if x>y then but I'm stumped as for comparing more than 3. Thanks for reading.
Use a public array rather than multiple variables. This will make it easy to iterate through them all and get the highest value, as well as reference the variable with the highest value later on:
Public myArray(0 To 2) As Integer
Public index As Integer
Public Sub calcMin()
Dim i As Integer
Dim maxValue As Integer
myArray(0) = 99
myArray(1) = 2
myArray(2) = 3
For i = 0 To UBound(myArray)
If myArray(i) < maxValue Then
maxValue = myArray(i)
index = i
End If
Next i
End Sub
Function yourFunction(valueToPass As Integer)
'your function's code here
End Function
Then pass the variable to yourFunction like so: yourFunction(myArray(index))
Same idea as Mike's but with an example to call a sub with the min value found:
Sub main()
Dim arrComp(2) As Integer
arrComp(0) = 99
arrComp(1) = 2
arrComp(2) = 3
'It is important to initialize the tmpVal to a value from the array
'to consider the chance where negative and positive values are used
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp))
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i) < tmpVal Then
tmpVal = arrComp(i)
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
Sub showMinVal(MinVal As Integer)
MsgBox "The min value is " & MinVal
End Sub
Or, a workaround if you want the name associated to the value, you could define a new Type:
'Types must be declared at the top of the module
Type tVarName
varName As String
varVal As Integer
End Type
Sub main()
Dim arrComp(2) As tVarName
arrComp(0).varName = "x"
arrComp(0).varVal = 99
arrComp(1).varName = "y"
arrComp(1).varVal = 2
arrComp(2).varName = "z"
arrComp(2).varVal = 3
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp)).varVal
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i).varVal < tmpVal Then
tmpVal = arrComp(i).varVal
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
'Sub showing min value along with the name associated to it
Sub showMinVal(MinVal As tVarName)
MsgBox "The min value is " & MinVal.varName & " = " & MinVal.varVal
End Sub

FILTER Function for integers - VBA

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

VBA. How to find position of first digit in string

I have string "ololo123".
I need get position of first digit - 1.
How to set mask of search ?
Here is a lightweight and fast method that avoids regex/reference additions, thus helping with overhead and transportability should that be an advantage.
Public Function GetNumLoc(xValue As String) As Integer
For GetNumLoc = 1 To Len(xValue)
If Mid(xValue, GetNumLoc, 1) Like "#" Then Exit Function
Next
GetNumLoc = 0
End Function
Something like this should do the trick for you:
Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPositionOfFirstNumericCharacter = i
Exit Function
End If
Next i
End Function
You can then call it like this:
Dim iPosition as Integer
iPosition = GetPositionOfFirstNumericCharacter("ololo123")
Not sure on your environment, but this worked in Excel 2010
'Added reference for Microsoft VBScript Regular Expressions 5.5
Const myString As String = "ololo123"
Dim regex As New RegExp
Dim regmatch As MatchCollection
regex.Pattern = "\d"
Set regmatch = regex.Execute(myString)
MsgBox (regmatch.Item(0).FirstIndex) ' Outputs 5
I actually have that function:
Public Function GetNumericPosition(ByVal s As String) As Integer
Dim result As Integer
Dim i As Integer
Dim ii As Integer
result = -1
ii = Len(s)
For i = 1 To ii
If IsNumeric(Mid$(s, i, 1)) Then
result = i
Exit For
End If
Next
GetNumericPosition = result
End Function
You could try regex, and then you'd have two problems. My VBAfu is not up to snuff, but I'll give it a go:
Function FirstDigit(strData As String) As Integer
Dim RE As Object REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "[0-9]"
End With
Set REMatches = RE.Execute(strData)
FirstDigit = REMatches(0).FirstIndex
End Function
Then you just call it with FirstDigit("ololo123").
If speed is an issue, this will run a bit faster than Robs (noi Rob):
Public Sub Example()
Const myString As String = "ololo123"
Dim position As Long
position = GetFirstNumeric(myString)
If position > 0 Then
MsgBox "Found numeric at postion " & position & "."
Else
MsgBox "Numeric not found."
End If
End Sub
Public Function GetFirstNumeric(ByVal value As String) As Long
Dim i As Long
Dim bytValue() As Byte
Dim lngRtnVal As Long
bytValue = value
For i = 0 To UBound(bytValue) Step 2
Select Case bytValue(i)
Case vbKey0 To vbKey9
If bytValue(i + 1) = 0 Then
lngRtnVal = (i \ 2) + 1
Exit For
End If
End Select
Next
GetFirstNumeric = lngRtnVal
End Function
An improved version of spere's answer (can't edit his answer), which works for any pattern
Private Function GetNumLoc(textValue As String, pattern As String) As Integer
For GetNumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, GetNumLoc, Len(pattern)) Like pattern Then Exit Function
Next
GetNumLoc = 0
End Function
To get the pattern value you can use this:
Private Function GetTextByPattern(textValue As String, pattern As String) As String
Dim NumLoc As Integer
For NumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, NumLoc, Len(pattern)) Like pattern Then
GetTextByPattern = Mid(textValue, NumLoc, Len(pattern))
Exit Function
End If
Next
GetTextByPattern = ""
End Function
Example use:
dim bill as String
bill = "BILLNUMBER 2202/1132/1 PT2200136"
Debug.Print GetNumLoc(bill , "PT#######")
'Printed result:
'24
Debug.Print GetTextByPattern(bill , "PT#######")
'Printed result:
'PT2200136