Excel VBA function returning an array - vba

Can you create an Excel VBA function that returns an array in the same manner as LINEST does, for example? I would to create one that, given a supplier code, returns a list of products for that supplier from a product-supplier table.

ok, here I have a function datamapping that returns an array of multiple 'columns', so you can shrink this down just to one.
Doesn't really matter how the array gets populated, particularly
Function dataMapping(inMapSheet As String) As String()
Dim mapping() As String
Dim lastMapRowNum As Integer
lastMapRowNum = ActiveWorkbook.Worksheets(inMapSheet).Cells.SpecialCells(xlCellTypeLastCell).Row
ReDim mapping(lastMapRowNum, 3) As String
For i = 1 To lastMapRowNum
If ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 1).Value <> "" Then
mapping(i, 1) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 1).Value
mapping(i, 2) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 2).Value
mapping(i, 3) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 3).Value
End If
Next i
dataMapping = mapping
End Function
Sub mysub()
Dim myMapping() As String
Dim m As Integer
myMapping = dataMapping(inDataMap)
For m = 1 To UBound(myMapping)
' do some stuff
Next m
end sub

I think Collection might be what you are looking for.
Example:
Private Function getProducts(ByVal supplier As String) As Collection
Dim getProducts_ As New Collection
If supplier = "ACME" Then
getProducts_.Add ("Anvil")
getProducts_.Add ("Earthquake Pills")
getProducts_.Add ("Dehydrated Boulders")
getProducts_.Add ("Disintegrating Pistol")
End If
Set getProducts = getProducts_
Set getProducts_ = Nothing
End Function
Private Sub fillProducts()
Dim products As Collection
Set products = getProducts("ACME")
For i = 1 To products.Count
Sheets(1).Cells(i, 1).Value = products(i)
Next i
End Sub
Edit:
Here is a pretty simple solution to the Problem: Populating a ComboBox for Products whenever the ComboBox for Suppliers changes it's value with as little vba as possible.
Public Function getProducts(ByVal supplier As String) As Collection
Dim getProducts_ As New Collection
Dim numRows As Long
Dim colProduct As Integer
Dim colSupplier As Integer
colProduct = 1
colSupplier = 2
numRows = Sheets(1).Cells(1, colProduct).CurrentRegion.Rows.Count
For Each Row In Sheets(1).Range(Sheets(1).Cells(1, colProduct), Sheets(1).Cells(numRows, colSupplier)).Rows
If supplier = Row.Cells(1, colSupplier) Then
getProducts_.Add (Row.Cells(1, colProduct))
End If
Next Row
Set getProducts = getProducts_
Set getProducts_ = Nothing
End Function
Private Sub comboSupplier_Change()
comboProducts.Clear
For Each Product In getProducts(comboSupplier)
comboProducts.AddItem (Product)
Next Product
End Sub
Notes: I named the ComboBox for Suppliers comboSupplier and the one for Products comboProducts.

Related

CATVBA - CATIA recursive loop throught Product Tree

Sorry but I'm a total newbie in CATScript.
But I'm looking for a solution that will provide me to check every node in my Product structure recursively.
I try to adopt the Fibonacci procedure:
Function Fib(n As Long) As Long
Dim first As Long
Dim second As Long
Dim sum As Long
Dim i As Long
first = 0
second = 1
sum = 0
If n = 0 Then
Fib = first
ElseIf n = 1 Then
Fib = second
Else
For i = 2 To n
sum = first + second
first = second
second = sum
Next i
Fib = sum
End If
End Function
with this:
Private Sub TestMain
Dim searchName As String
searchName = "SearchName"
' Start with the selected object
Dim doc As Document
Set doc = CATIA.ActiveDocument
Dim prod As Product
Set prod = doc.Product
Dim foundItem As Object
foundItem = TestMainChildren(doc.Selection.Item(1).Value, searchName)
MsgBox "Found: " & foundItem.Name
End Sub
Private Function TestMainChildren(ByRef catiaObject As Object, ByVal searchName As String) As Object
Dim item As Object
For Each item In catiaObject.Items
If item.Name = "SearchName" then
Set TestMainChildren = item
Exit For
End if
Dim catiaType As String
catiaType = TypeName(item)
If catiaType = "Product" Then
TestMainChildren item, searchName
End If
Next
End Sub
but I have no idea how to do this. Can anybody help here?
It depends on what you want, but it is often very useless to check all the instances whith a recursive loop.
what is your end goal?
i suggest you to check every instance opened :
Sub main()
Dim d As Document
For Each d In CATIA.Documents
Dim p As Product
Set p = d.Product
MsgBox (p.Name)
Next
End Sub
If you insist and really want a recursive loop :
Sub main()
Dim d As Document
Set d = CATIA.ActiveDocument
Dim p As Product
Set p = d.Product
Call RecursiveAllProducts(p) 'here your recursive starts
End Sub
Sub RecursiveAllProducts(p As Product) 'your recursive
MsgBox (p.PartNumber)
If p.Products.Count > 0 Then
For i = 1 To p.Products.Count
Dim p_ As Product
Set p_ = p.Products.Item(i)
Call RecursiveAllProducts(p_) 'you call your recursive again
Next i
End If
End Sub

get property form an object in a collection (VBA)

I create a collection of custom class objects, I am able to retrieve all the object property except for amount property (which is an array)
the following is my code
Sub Ledger()
Dim ActPeriod As Long
Dim ForcastPeriod As Long
Dim sth As Worksheet
Dim Account As New ClsAccount
Dim allaccounts As New Collection
ActPeriod = 3
ForecastPeriod = 3
For i = 1 To Sheet1.Range("A4:A26").count
If Sheet1.Cells(i, 1) <> 0 Then
counter = counter + 1
Set Account = New ClsAccount
With Account
.Code = Sheet1.Cells(i, 1)
.Name = Sheet1.Cells(i, 2)
.amount = Sheet1.Range(Cells(i, 3), Cells(i, 2 + ActPeriod))
allaccounts.add Account, .Code
End With
End If
Next i
MsgBox allaccounts(3).amount(1, 1)
End Sub
the code I used to create the class is as follow
Private AccAmount As Variant
Private AccGrowth As Variant
Private AccName As String
Private AccCode As String
Property Let amount(amt As Variant)
AccAmount = amt
End Property
Property Get amount() As Variant
amount = AccAmount
End Property
Property Let Name(n As String)
AccName = n
End Property
Property Get Name() As String
Name = AccName
End Property
Property Let Code(c As String)
AccCode = c
End Property
Property Get Code() As String
Code = AccCode
End Property
I am getting this error
MsgBox allaccounts(3).amount()(1, 1)
Without the parentheses VBA thinks you're trying to pass 1, 1 to the Property Get procedure, and that's not defined with any parameters...

Excel VBA: MoviesByGenre Function

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:

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.

A practical example of evenly distributing n lists into a single list

I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)