If I have the following array:
Dim Array(4, 10) As String
Array(0, 0) = "100"
Array(0, 1) = "200"
Array(1, 0) = "300"
Array(1, 1) = "400"
Array(1, 2) = "500"
Array(1, 3) = "600"
How do I get the following count:
0 = 2
1 = 4
It sounds like you're trying to count the number of non-Nothing values in each dimension of the array. The following function will allow you to do that
Public Function CountNonNothing(ByVal data As String(,), ByVal index As Integer) As Integer
Dim count = 0
For j = 0 To data.GetLength(1) - 1
If data(index, j) IsNot Nothing Then
count += 1
End If
Next
Return count
End Function
And it can be invoked like so
Dim count1 = CountNonNothing(Array, 0)
Dim count2 = CountNonNothing(Array, 1)
Note: I used a C# to VB converter so hopefully the VB syntax is correct.
I made a simple extension method that makes this pretty easy:
Public NotInheritable Class Extensions
Private Sub New()
End Sub
<System.Runtime.CompilerServices.Extension> _
Public Shared Function GetNonNullItems(Of T)(array As T(,), index As Integer) As IEnumerable(Of T)
For i As Integer = 0 To array.GetLength(index) - 1
If array(index, i) IsNot Nothing Then
yield Return array(index, i)
End If
Next
End Function
End Class
Then to use it:
Dim Array As String(,) = New String(4, 10) {}
Array(0, 0) = "100"
Array(0, 1) = "200"
Array(1, 0) = "300"
Array(1, 1) = "400"
Array(1, 2) = "500"
Array(1, 3) = "600"
Dim countArray0 As Integer = Array.GetNonNullItems(0).Count()
Dim countArray1 As Integer = Array.GetNonNullItems(1).Count()
The extension method will give you back all non null items found for a given index. From that you can get the count, filter, query, or use them however you want.
Converted from c# but it could be something like this.
Dim count As Integer() = New Integer(Array.GetLength(0) - 1) {}
For i As Integer = 0 To Array.GetLength(0) - 1
For j As Integer = 0 To Array.GetLength(1) - 1
If Array(i, j) IsNot Nothing Then
count(i) += 1
End If
Next
Next
Now count of 0's would be in count(0), count of 1's would be in count(1), so on...
Related
I currently have a routine that searches up through the directory where a file is saved and finds a folder called "$Fabrication Data".
I am working on a new addition that will be subbed into my existing code to allow for some human error, aka slight misspelling/misformating if that folder name.
I would like to examine each folder in the 'Path' directory (but not its sub folders). Currently it returns a match:
Path\SubFolder$Fabrication Data$
instead if the path I want:
Path$ Fabrication Data
Bonus question... I am currently returning any folder that is above a .8 match, how can I return the closest match if there are multiple folders above .8 match?
Dim Path As String = "N:\Stuff\More Stuff\More More Stuff\Project Folder"
For Each d In System.IO.Directory.GetDirectories(Path)
For Each sDir In System.IO.Directory.GetDirectories(d)
Dim sdirInfo As New System.IO.DirectoryInfo(sDir)
Dim similarity As Single = GetSimilarity(sdirInfo.Name, "$Fabrication Data")
If similarity > .8 Then
sFDPath = Path & "\" & sdirInfo.Name
MsgBox(sFDPath)
Else
End If
Next
Next
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function ```
You can track the ratings for each folder using a simple class like this:
Public Class FolderRating
Public Rating As Single
Public Folder As String
Public Sub New(folder As String, rating As Single)
Me.Folder = folder
Me.Rating = rating
End Sub
End Class
Then, create a List:
Dim ratings As New List(Of FolderRating)
In your loop, when you find a rating that is above 0.8, add it to the list:
If similarity > 0.8 Then
Dim sFDPath As String = Path & "\" & sdirInfo.Name
ratings.Add(New FolderRating(sFDPath, similarity))
End If
Finally, sort the list:
ratings.Sort(Function(x, y) x.Rating.CompareTo(y.Rating))
You can then take the last value in the list and it will be your most similar folder, if any:
Dim bestMatch As FolderRating = ratings.LastOrDefault
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
Right, so using Python I would create a multidimensional list and set the values on one line of code (as per the below).
aryTitle = [["Desciption", "Value"],["Description2", "Value2"]]
print(aryTitle[0,0] + aryTitle[0,1])
I like the way I can set the values on one line. In VBA I am doing this by:
Dim aryTitle(0 To 1, 0 To 1) As String
aryTitle(0, 0) = "Description"
aryTitle(0, 1) = "Value"
aryTitle(1, 0) = "Description2"
aryTitle(1, 1) = "Value2"
MsgBox (aryTitle(0, 0) & aryTitle(0, 1))
Is there a way to set the values in one line of code?
Not natively, no. But you can write a function for it. The only reason Python can do that is someone wrote a function to do it. The difference is that they had access to the source so they could make the syntax whatever they like. You'll be limited to VBA function syntax. Here's a function to create a 2-dim array. It's not technically 'one line of code', but throw it in your MUtilities module and forget about it and it will feel like one line of code.
Public Function FillTwoDim(ParamArray KeyValue() As Variant) As Variant
Dim aReturn() As Variant
Dim i As Long
Dim lCnt As Long
ReDim aReturn(0 To ((UBound(KeyValue) + 1) \ 2) - 1, 0 To 1)
For i = LBound(KeyValue) To UBound(KeyValue) Step 2
If i + 1 <= UBound(KeyValue) Then
aReturn(lCnt, 0) = KeyValue(i)
aReturn(lCnt, 1) = KeyValue(i + 1)
lCnt = lCnt + 1
End If
Next i
FillTwoDim = aReturn
End Function
Sub test()
Dim vaArr As Variant
Dim i As Long
Dim j As Long
vaArr = FillTwoDim("Description", "Value", "Description2", "Value2")
For i = LBound(vaArr, 1) To UBound(vaArr, 1)
For j = LBound(vaArr, 2) To UBound(vaArr, 2)
Debug.Print i, j, vaArr(i, j)
Next j
Next i
End Sub
If you supply an odd number of arguments, it ignores the last one. If you use 3-dim arrays, you could write a function for that. You could also write a fancy function that could handle any dims, but I'm not sure it's worth it. And if you're using more than 3-dim arrays, you probably don't need my help writing a function.
The output from the above
0 0 Description
0 1 Value
1 0 Description2
1 1 Value2
You can write a helper function:
Function MultiSplit(s As String, Optional delim1 As String = ",", Optional delim2 As String = ";") As Variant
Dim V As Variant, W As Variant, A As Variant
Dim i As Long, j As Long, m As Long, n As Long
V = Split(s, delim2)
m = UBound(V)
n = UBound(Split(V(0), delim1))
ReDim A(0 To m, 0 To n)
For i = 0 To m
For j = 0 To n
W = Split(V(i), delim1)
A(i, j) = Trim(W(j))
Next j
Next i
MultiSplit = A
End Function
Used like this:
Sub test()
Dim A As Variant
A = MultiSplit("Desciption, Value; Description2, Value2")
Range("A1:B2").Value = A
End Sub
I would like to format my listbox so that the output becomes something like this.
This is method, not in the main form tho:
Public Function GetSeatInfoStrings(ByVal choice As DisplayOptions,
ByRef strSeatInfoStrings As String()) As Integer
Dim count As Integer = GetNumOfSeats(choice)
If (count <= 0) Then
Return 0
End If
strSeatInfoStrings = New String(count - 1) {}
Dim StrReservation As String = ""
strSeatInfoStrings = New String(count - 1) {}
Dim i As Integer = 0 'counter for return array
'is the element corresponding with the index empty
For index As Integer = 0 To m_totNumOfSeats - 1
Dim strName As String = ""
Dim reserved As Boolean = Not String.IsNullOrEmpty(m_nameList(index))
'if the criteria below are not met, skip to add info in the array
If (choice = DisplayOptions.AllSeats) Or
(reserved And choice = DisplayOptions.ReservedSeats) Or
((Not reserved) And (choice = DisplayOptions.VacantSeats)) Then
If (reserved) Then
StrReservation = "Reserved"
strName = m_nameList(index)
Else
StrReservation = "Vacant"
strName = "..........."
End If
strSeatInfoStrings(i) = String.Format("{0,4} {1,-8} {2, -20} {3,10:f2}",
index + 1, StrReservation, strName, m_priceList(index))
i += 1
End If
Next
Return count
End Function
I don't know how to format the listbox as the strSeatInfoStrings(i) in the main form.
My listbox
This is what I've done
Private Sub UpdateGUI()
'Clear the listbox and make it ready for new data.
ReservationList.Items.Clear()
'size of array is determined in the callee method
Dim seatInfoStrings As String() = Nothing
Dim calcOption As DisplayOptions = DirectCast(cmbDisplayOptions.SelectedIndex, DisplayOptions)
Dim count As Integer = m_seatMngr.GetSeatInfoStrings(calcOption, seatInfoStrings)
If count > 0 Then
ReservationList.Items.AddRange(seatInfoStrings)
Else
ReservationList.Items.Add("Nothing to display!")
End If
Found the error! I forgot to call the UpdateGUI() in the IntializeGUI().
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.