Function is only working for certain subranges? - vba

Main point of this function is to return the most common movie genre.
Function MoviesByGenre(genreRng As Range) As String
Dim genreList(1 To 4) As String
Dim current As Integer
current = 1
For i = 1 To genreRng.count
Dim found As Integer
found = 0
For j = 1 To current
If genreList(j) = genreRng.Cells(i) Then
found = 1
Exit For
End If
Next j
If found = 0 Then
genreList(current) = genreRng.Cells(i)
current = current + 1
End If
Next i
Dim genreCount(1 To 4) As Integer
For i = 1 To 4
Dim count As Integer
count = 0
For j = 1 To genreRng.count
If genreRng.Cells(j) = genreList(i) Then
count = count + 1
End If
Next j
genreCount(i) = count
Next i
MoviesByGenre = FindMax(genreCount, genreList)
End Function
Now my FindMax function looks like this:
Function FindMax(valueArray, nameArray) As String
Dim max As Double
max = valueArray(LBound(valueArray))
For i = LBound(valueArray) + 1 To UBound(valueArray)
If valueArray(i) > valueArray(max) Then
max = i
End If
Next i
FindMax = nameArray(max)
End Function
FindMax appears to work well in other areas, but depending on the range I use for MoviesByGenre, it may or may not work. (sometimes it'll give me #VALUE!, other times it'll give me the actual most common movie genre, and i'm not sure why.) I'm using Excel 2016 for MacOS.

Do you mean something like that
Sub Test()
Dim a As Variant
a = Range("A1:A7").Value
MsgBox FindMax(a)
End Sub
Function FindMax(valueArray) As String
Dim max As Double
Dim i As Long
max = valueArray(LBound(valueArray), 1)
For i = LBound(valueArray) + 1 To UBound(valueArray)
If valueArray(i, 1) > max Then
max = valueArray(i, 1)
End If
Next i
FindMax = max
End Function

Related

DataTable.Rows.Count always returns 0 - VB.NET

I'm trying to populate DataGridView cells with information from two (parent, child tables). Everything works just fine, except for this part table.Rows.Count. It always returns 0, no matter that I have one record in the table.
This is the code:
Private Sub Query__tbl_purchase_order_articlesDataGridView_CellEndEdit(sender As Object, e As DataGridViewCellEventArgs) Handles Query__tbl_purchase_order_articlesDataGridView.CellEndEdit
Dim table As DataTable = Orders_DBDataSet.Tables("tbl_list_of_articles")
Dim selectedRowCount As Integer = Query__tbl_purchase_order_articlesDataGridView.CurrentCell.RowIndex
Dim art_ID As Integer = CInt(Query__tbl_purchase_order_articlesDataGridView.Rows(selectedRowCount).Cells(0).Value)
Dim art_ttl As String
Dim art_ttl_tr As String
Dim mu As String
Dim art_ttl_i As Integer
Dim art_ttl_tr_i As Integer
Dim mu_i As Integer
Dim art_ID_t_i As Integer
Dim art_ttl_t_i As Integer
Dim art_ttl_tr_t_i As Integer
Dim mu_t_i As Integer
Dim i As Integer
'search for column index in DataGridView
For i = 0 To Query__tbl_purchase_order_articlesDataGridView.Columns.Count - 1
If Query__tbl_purchase_order_articlesDataGridView.Columns(i).HeaderText.ToString = "article_name" Then
art_ttl_i = i
End If
If Query__tbl_purchase_order_articlesDataGridView.Columns(i).HeaderText.ToString = "article_name_tr" Then
art_ttl_tr_i = i
End If
If Query__tbl_purchase_order_articlesDataGridView.Columns(i).HeaderText.ToString = "masurement_unit" Then
mu_i = i
End If
Next
'search for column index in "table"
For i = 0 To table.Columns.Count - 1
If table.Columns(i).ColumnName.ToString = "article_ID" Then
art_ID_t_i = i
End If
If table.Columns(i).ColumnName.ToString = "article_name" Then
art_ttl_t_i = i
End If
If table.Columns(i).ColumnName.ToString = "article_name_tr" Then
art_ttl_tr_t_i = i
End If
If table.Columns(i).ColumnName.ToString = "masurement_unit" Then
mu_t_i = i
End If
Next
For i = 0 To table.Rows.Count
If art_ID = CInt(table.Rows(i).Item(art_ID_t_i).ToString()) Then
art_ttl = table.Rows(i).Item(art_ttl_t_i).ToString()
art_ttl_tr = table.Rows(i).Item(art_ttl_tr_t_i).ToString()
mu = table.Rows(i).Item(mu_t_i).ToString()
Query__tbl_purchase_order_articlesDataGridView.Rows(selectedRowCount).Cells(art_ttl_i).Value = art_ttl
Query__tbl_purchase_order_articlesDataGridView.Rows(selectedRowCount).Cells(art_ttl_tr_i).Value = art_ttl_tr
Query__tbl_purchase_order_articlesDataGridView.Rows(selectedRowCount).Cells(mu_i).Value = mu
Exit For
End If
Next
End Sub
Also, I tied to test it like this, but the result is the same. It can find a table index, but always return 0 as a table row count.
'test ========================================
Dim x, y As Integer
For x = 0 To Orders_DBDataSet.Tables.Count - 1
If Orders_DBDataSet.Tables(x).TableName.ToString = "tbl_list_of_articles" Then
y = x
End If
Next
x = 0
For Each row As DataRow In table.Rows
x = x + 1
Next
'============================================
x = Orders_DBDataSet.Tables(y).Rows.Count
Most of the times this happened to me because I was not actually using the instance of the dataset "connected" to the form. What does this mean? You either don't populate the dataset instance tied to the form in the Load event, or you are populating it but you are somehow using other instance of it. This has a higher chance of happening if you are sending data between forms as well.

Count number of unbroken 'strings' of numbers across a row in VBA Function

I have been battling this one for days, and am clearly missing something. It has been a while since I last used VBA and I am struggling to remember.
Looking to find the number of 'tours' or uninterupted 'strings' of 1's across a row.
Data and answer I am looking for is this (with each number being in its own column):
0 0 1 1 1 0 1 0 1 = 3
1 0 0 0 0 0 0 0 0 = 1
0 0 0 0 1 1 1 1 1 = 1
Have tried the following Functions:
Function TOURCOUNT(TourList As Range)
Dim var As Variant
var = TourList.Value
For Each var In TourList
If var = 1 And var + 1 = 1 Then
TOURCOUNT = TOURCOUNT
ElseIf var = 1 Then
TOURCOUNT = TOURCOUNT + 1
End If
Next
End Function
And just running through the cells:
Function NTOURS(TList As Range)
Dim var As Variant
For Each Cell In TList
If Cell.Offset(0, 1).Value = 1 And Cell.Value = 1 Then
NTOURS = NTOURS + 1
End If
Next
End Function
And a few other minor variations. Clearly I am not understanind something correctly. The 'And' evaluate Offset if statement returned the wrong numbers when I accidently offset rows instead of columns. But when I correct that it just returns 0.
Any help would be greatly appreciated!!
Thank you!
I am not sure what you are trying to do, but judging from your examples, something like this would do the work.
In general, you pass the range as a parameter, it goes in the row and it makes two checks pro case in the loop. If both checks are successful, lngResult is incremented.
Option Explicit
Public Function Uninterrupted(rngRange As Range) As Long
Dim rngCell As Range
Dim lngResult As Long
Dim blnInterruped As Boolean
For Each rngCell In rngRange
If rngCell Then
If Not blnInterruped Then lngResult = lngResult + 1
blnInterruped = True
Else
blnInterruped = False
End If
Next rngCell
Uninterrupted = lngResult
End Function

Fetch the maximum value from an array

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

How can I list all the combinations that meet certain criteria using Excel VBA?

Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.

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