Unique Entries in Userform Dependent Listboxes

Posted on July 27, 2016August 1, 2016 by Dick Kusleika

…could you please help me tweak the code so that I can make multiple selections in listbox 1 in such a way that the values selected in list box two has all the values applicable for the selections made (listbox) but removes all duplicates?

First, a word about that post. I have used the relationship listbox template exactly zero times. I simply prefer to build my classes from scratch with names that reflect the business objects they represent. But I did reuse the userform and I didn’t change the control names from Parent/Child to Class/Student. I’m conflicted about that, but I’ll get over it.

Let’s say we have some classes and students. A class can have many students and a student can have many classes.

When you select a class, the userform lists the students. If you select more than one class, the userform lists all the student from the selected classes, but each student is listed only once.

Andrew and Payton are only listed once.

There are some significant changes to the code, not the least of which is removing the grandchildren. Also instead of tracking ActiveParent (singular), I now track ActiveClasses (plural) because my top listbox is now multiselect. When my Parent listbox changes, I have to see all the classes that are selected.

Private Sub lbxParents_Change()

    Dim clsClass As CClass
    Dim i As Long

    If Me.lbxParents.ListIndex &lt;&gt; -1 Then
        Set Me.ActiveClasses = New CClasses
        For i = 0 To Me.lbxParents.ListCount - 1
            If Me.lbxParents.Selected(i) Then
                Me.ActiveClasses.Add Me.Classes.ClassByClassName(Me.lbxParents.List(i))
            End If
        Next i
    Else
        Set Me.ActiveClasses = Nothing
    End If

    FillChildren

End Sub

Private Sub FillChildren()

    Me.lbxChildren.Clear

    If Not Me.ActiveClasses Is Nothing Then
        If Me.ActiveClasses.StudentCount &gt; 0 Then
            Me.lbxChildren.List = Me.ActiveClasses.StudentList
            Me.lbxChildren.ListIndex = 0
        End If
    End If


End Sub

Private Sub lbxParents_Change()

Dim clsClass As CClass

Dim i As Long

If Me.lbxParents.ListIndex <> -1 Then

Set Me.ActiveClasses = New CClasses

For i = 0 To Me.lbxParents.ListCount - 1

If Me.lbxParents.Selected(i) Then

Me.ActiveClasses.Add Me.Classes.ClassByClassName(Me.lbxParents.List(i))

End If

Next i

Else

Set Me.ActiveClasses = Nothing

End If

FillChildren

End Sub

Private Sub FillChildren()

Me.lbxChildren.Clear

If Not Me.ActiveClasses Is Nothing Then

If Me.ActiveClasses.StudentCount > 0 Then

Me.lbxChildren.List = Me.ActiveClasses.StudentList

Me.lbxChildren.ListIndex = 0

End If

End Sub

To get a unique student list, I use a dictionary object. My favorite thing about dictionaries is returning a zero-based array from the Keys or Items properties.

Public Property Get StudentList() As Variant

    Dim clsClass As CClass
    Dim clsStudent As CStudent
    Dim dcReturn As Scripting.Dictionary

    Set dcReturn = New Scripting.Dictionary
    
    For Each clsClass In Me
        For Each clsStudent In clsClass.Students
            If Not dcReturn.Exists(clsStudent.StudentName) Then
                dcReturn.Add clsStudent.StudentName, clsStudent.StudentName
            End If
        Next clsStudent
    Next clsClass
    
    StudentList = dcReturn.Keys
    
End Property

Public Property Get StudentList() As Variant

Dim clsClass As CClass

Dim clsStudent As CStudent

Dim dcReturn As Scripting.Dictionary

Set dcReturn = New Scripting.Dictionary

For Each clsClass In Me

For Each clsStudent In clsClass.Students

If Not dcReturn.Exists(clsStudent.StudentName) Then

dcReturn.Add clsStudent.StudentName, clsStudent.StudentName

End If

Next clsStudent

Next clsClass

StudentList = dcReturn.Keys

End Property

You can check out the rest of the code in the downloadable file.

You can download ParentChildUserformMulti.zip

Cleaning Up My JoinRange Arguments

Posted on June 22, 2016 by Dick Kusleika

I’m trying to make my JoinRange function better and I’m failing miserably. A few years ago I added a “macro” argument because I was making so many HTML and Trac tables. I don’t use Trac anymore and I almost never make HTML tables (because I blog so infrequently, I guess). I got rid of that argument. The reason I join ranges most often is to create a big

In

clause in SQL. Let’s say I have this list of customer IDs and I want to make an

In

clause.

142

146

175

214

217

I’d use JoinRange like

=JoinRange(A2:A7,,"','","('","')")

1	=JoinRange(A2:A7,,"','","('","')")

That’s a freakin’ mess. The second argument is the now-defunct macro argument and is blank. The rest of the arguments are

3rd (delimeter): single quote, comma, single quote
4th (beginning): open paren, single quote
5th (ending): single quote, close paren

and I’d get

('38','142','146','175','214','217')

1	('38','142','146','175','214','217')

which I could paste into my SQL statement and roll. I hate typing those arguments. Worse, I hate reading those arguments. It’s pretty hard to read in this blog, but it’s worse in Excel’s formula bar. I thought if I could get rid of the single quotes, it would be cleaner. I rewrote the code to add a Quote argument that would wrap every entry in whatever quotes I supplied.

Public Function JoinRange(rInput As Range, _
    Optional sDelim As String = vbNullString, _
    Optional sLineStart As String = vbNullString, _
    Optional sLineEnd As String = vbNullString, _
    Optional sBlank As String = vbNullString, _
    Optional sQuotes As String = vbNullString) As String
    
    Dim vaCells As Variant
    Dim i As Long, j As Long
    Dim lCnt As Long
    Dim aReturn() As String
    
    vaCells = rInput.Value
    ReDim aReturn(1 To rInput.Cells.Count)
    
    For i = LBound(vaCells, 1) To UBound(vaCells, 1)
        For j = LBound(vaCells, 2) To UBound(vaCells, 2)
            lCnt = lCnt + 1
            If Len(vaCells(i, j)) = 0 Then
                aReturn(lCnt) = sQuotes & sBlank & sQuotes
            Else
                aReturn(lCnt) = sQuotes & vaCells(i, j) & sQuotes
            End If
        Next j
    Next i
    
    JoinRange = sLineStart & Join(aReturn, sDelim) & sLineEnd
    
End Function

Public Function JoinRange(rInput As Range, _

Optional sDelim As String = vbNullString, _

Optional sLineStart As String = vbNullString, _

Optional sLineEnd As String = vbNullString, _

Optional sBlank As String = vbNullString, _

Optional sQuotes As String = vbNullString) As String

Dim vaCells As Variant

Dim i As Long, j As Long

Dim lCnt As Long

Dim aReturn() As String

vaCells = rInput.Value

ReDim aReturn(1 To rInput.Cells.Count)

For i = LBound(vaCells, 1) To UBound(vaCells, 1)

For j = LBound(vaCells, 2) To UBound(vaCells, 2)

lCnt = lCnt + 1

If Len(vaCells(i, j)) = 0 Then

aReturn(lCnt) = sQuotes & sBlank & sQuotes

Else

aReturn(lCnt) = sQuotes & vaCells(i, j) & sQuotes

End If

Next j

Next i

JoinRange = sLineStart & Join(aReturn, sDelim) & sLineEnd

End Function

Now, my formula looks like this:

=JoinRange(A2:A7,",","(",")",,"'")

1	=JoinRange(A2:A7,",","(",")",,"'")

I think we can all agree that this is no better than what I had before. I thought the quotes were the problem, but it’s also that I use a comma as the delimiter and it’s the thing that separates the arguments. If I change it to pipe delimited…

=JoinRange(A2:A7,"|","(",")",,"'")

1	=JoinRange(A2:A7,"\|","(",")",,"'")

Nope. It’s still a headache to read. Based on the number of comments to this post, I’m pretty sure none of you are using predefined names in your book.xlt file. But I do. And If I’m using a workbook that I created, I could use

=JoinRange(A2:A7,xlCOMMA,"(",")",xlSINGLE)

1	=JoinRange(A2:A7,xlCOMMA,"(",")",xlSINGLE)

That’s definitely more readable to me. I guess I need a macro to add those names to any books automatically so I can use them.

Public Sub AddConstantNames()
    
    ActiveWorkbook.Names.Add "xlCOMMA", "="","""
    ActiveWorkbook.Names.Add "xlSPACE", "="" """
    ActiveWorkbook.Names.Add "xlDOUBLE", "="""""
    ActiveWorkbook.Names.Add "xlSINGLE", "=""'"""
    ActiveWorkbook.Names.Add "xlPARENO", "=""("""
    ActiveWorkbook.Names.Add "xlPARENC", "="")"""
    ActiveWorkbook.Names.Add "xlPIPE", "=""|"""
    
End Sub

Public Sub AddConstantNames()

ActiveWorkbook.Names.Add "xlCOMMA", "="","""

ActiveWorkbook.Names.Add "xlSPACE", "="" """

ActiveWorkbook.Names.Add "xlDOUBLE", "="""""

ActiveWorkbook.Names.Add "xlSINGLE", "=""'"""

ActiveWorkbook.Names.Add "xlPARENO", "=""("""

ActiveWorkbook.Names.Add "xlPARENC", "="")"""

ActiveWorkbook.Names.Add "xlPIPE", "=""|"""

End Sub

=JoinRange(A2:A7,xlCOMMA,xlPARENO,xlPARENC,xlSINGLE)

1	=JoinRange(A2:A7,xlCOMMA,xlPARENO,xlPARENC,xlSINGLE)

I’m not crazy. I swear this all makes sense in my head. Plus, if you’ve read this far, you’re probably crazy too.

Anagrams and Palindromes

Posted on January 14, 2016 by Dick Kusleika

More Java homework:

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean
    
    Dim vaOne As Variant
    Dim vaTwo As Variant
    Dim bReturn As Boolean
    Dim i As Long
    
    Const sRPLC As String = "+"
    
    sWordOne = Replace(sWordOne, Space(1), vbNullString)
    sWordTwo = Replace(sWordTwo, Space(1), vbNullString)
    
    If Len(sWordOne) = Len(sWordTwo) Then
        For i = 1 To Len(sWordOne)
            sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)
        Next i
        bReturn = sWordTwo = String(Len(sWordOne), sRPLC)
    Else
        bReturn = False
    End If
    
    IsAnagram = bReturn
    
End Function

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean

Dim vaOne As Variant

Dim vaTwo As Variant

Dim bReturn As Boolean

Dim i As Long

Const sRPLC As String = "+"

sWordOne = Replace(sWordOne, Space(1), vbNullString)

sWordTwo = Replace(sWordTwo, Space(1), vbNullString)

If Len(sWordOne) = Len(sWordTwo) Then

For i = 1 To Len(sWordOne)

sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)

Next i

bReturn = sWordTwo = String(Len(sWordOne), sRPLC)

Else

bReturn = False

End If

IsAnagram = bReturn

End Function

First, I remove all the spaces. Then I make sure the two words are the same length. Then I loop through all the letters in the first word, find them in the second word, and replace them with a plus sign. If the second word is all plus signs at the end, then it’s an anagram. My first thought was to put the letters in an array and sort them, but that’s too much looping.

Public Function IsPalindrome(ByVal sPhrase As String)
    
    Dim i As Long
    Dim bReturn As Boolean
    
    bReturn = True
    sPhrase = Replace(sPhrase, Space(1), vbNullString)
    
    For i = 1 To Len(sPhrase)
        If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then
            bReturn = False
            Exit For
        End If
    Next i
    
    IsPalindrome = bReturn
    
End Function

Public Function IsPalindrome(ByVal sPhrase As String)

Dim i As Long

Dim bReturn As Boolean

bReturn = True

sPhrase = Replace(sPhrase, Space(1), vbNullString)

For i = 1 To Len(sPhrase)

If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then

bReturn = False

Exit For

End If

Next i

IsPalindrome = bReturn

End Function

Nothing too fancy here. Again, I remove all the spaces. Then I compare the first letter to the last letter, the second letter to the penultimate letter, and so on. If there’s every not a match, set the return value to False and quit looking.

Retrieving Data from Add-in Worksheets

Posted on December 9, 2015December 8, 2015 by Dick Kusleika

Add-ins have worksheets. You just can’t see them. But you can store information on them and it’s a good way to store settings, preferences, and other data. When you want to get to that data, you can go to the Properties for ThisWorkbook and change the IsAddin property to False. Now you can see the worksheets and change the data if necessary.

When you’re done, go back to the VBE and change the IsAddin property back to True before you save your changes. Don’t forget that part; it’s important.

I have a list of vendor codes stored on a worksheet in an addin. I need to see the list, but not change it. I didn’t want to go through all the IsAddin rigmarole, so I did this in the Immediate Window.

wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value

1	wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value

That part returns a two-dimensional array of all the values in the first column

application.transpose(...)

1	application.transpose(...)

That turns a two-dimensional array into a one-dimensional array.

?join(...,",")

1	?join(...,",")

That turns an array into a string with commas between the values. In retrospect, I should have used

?join(application.transpose(wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value),vbnewline)

1	?join(application.transpose(wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value),vbnewline)

to get each code on its own line. Here’s a way to put it into a range, if that’s where you’re going with it anyway.

wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.Copy workbooks.Add.Worksheets(1).cells(1,1)

1	wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.Copy workbooks.Add.Worksheets(1).cells(1,1)

Announcing Excel Summit South: Auckland Sydney Melbourne in March 2016

Posted on November 23, 2015 by Charles Williams

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

If you use, rely on, tell stories with, worry about, or operate in the advanced areas of Excel, then there’s a track designed just for you.

EXTEND YOUR SKILLS

This is a unique opportunity to:

Learn from six of the world’s leading Excel MVP’s as they discuss the Excel topics most useful to you.
Hear industry leading speakers from around the world give you the latest views on Financial Modelling best practices, standards and spreadsheet risk.
Shape the future of Excel: Interact with members of the Microsoft Excel Dev Team as you explore with them the future of Excel.
Choose the sessions that best suit your needs from 23 masterclass sessions over two days of twin tracks for modellers and analysts.

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

Use your opportunities, including two Panel discussions and Q&A sessions, throughout the two days to ask questions and discuss with the Excel MVPs and the industry experts.
The Excel Dev Team members will use this opportunity to learn from their customers, understand how you use Excel and get feedback on your Excel experience.

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

The ModelOff Meetup event delivers plenty of opportunities to mingle, learn from your peers, talk to the speakers and have fun.

PROUDLY SUPPORTED BY

Editing SQL Statements in External Data Queries

Posted on October 8, 2015 by Dick Kusleika

Surprisingly, I’ve been using the

SendKeys

SendKeys

macro from this post quite a bit. SendKeys is dangerous, as I’ve said, but I like to live on the edge. Jan Karel commented that I should use Alt-DDE, which gives me the Command Text box to edit the SQL query, but doesn’t give me the opportunity to change the name of the Connection. As I thought about it more, changing the Connection name happens one time and isn’t really the major source of my frustration. In fact, if I were a little more disciplined I could change the name when I setup the Connection in the Friendly Name box.

Then it’s settled. I’ll use Alt-DDE to edit the SQL and I’ll force myself to set the name when I set it up. But wait. One of the things I was really looking forward to in building my own Command Text box was making it bigger by default so I could see the whole SQL string (or at least most of it). The Alt-DDE textbox is only slightly better than the Connection properties Command Text textbox. See for yourself.

That’s a crappy UI. And that’s from someone who spends a lot of time in the Visual Basic Editor.

Then it’s settled. I’ll build my own form for changing the properties I want to change. It’s what I really wanted to do anyway, so why stop lying to myself. What kind of features should I build into this UI? A big textbox is a must. Also, I’d like to be able to add white space and line breaks. Oh, and if I could have SQL parsing, autoformatting, and autocomplete… So basically what I want is SQL Server Management Studio. I already have that. It’s called SQL Server Management Studio. That lead me to my next bit of genius. If I want to edit the SQL, even only a little, I should do it in SSMS. I added a couple of buttons to the Ribbon.

The Copy button copies the SQL to the clipboard, ready for me to paste into SSMS.

Public Sub CopySql()
    
    Dim doClip As MSForms.DataObject
    Dim qt As QueryTable
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        Set doClip = New DataObject
        doClip.SetText qt.CommandText
        doClip.PutInClipboard
    End If
    
End Sub

Public Sub CopySql()

Dim doClip As MSForms.DataObject

Dim qt As QueryTable

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

Set doClip = New DataObject

doClip.SetText qt.CommandText

doClip.PutInClipboard

End If

End Sub

I leave the button enabled and check to make sure a QueryTable exists in the procedure. If I wanted to enable/disable the button, I would need to run a SelectionChange event constantly. I didn’t test it, but it seems like too much overhead. The Paste button looks like this

Public Sub PasteSql()
    
    Dim doClip As MSForms.DataObject
    Dim qt As QueryTable
    Dim sOld As String
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        sOld = qt.CommandText
        Set doClip = New DataObject
        doClip.GetFromClipboard
        qt.CommandText = doClip.GetText
        doClip.SetText sOld
        doClip.PutInClipboard
    End If
    
End Sub

Public Sub PasteSql()

Dim doClip As MSForms.DataObject

Dim qt As QueryTable

Dim sOld As String

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

sOld = qt.CommandText

Set doClip = New DataObject

doClip.GetFromClipboard

qt.CommandText = doClip.GetText

doClip.SetText sOld

doClip.PutInClipboard

End If

End Sub

I added one little safety step in here because I know how I am. I take what’s in the clipboard and insert it into the

CommandText

1	CommandText

property. But I put the previous

CommandText

1	CommandText

in the Clipboard when I’m done. That way, when I get distracted and accidentally put something else in the Clipboard before I paste, I can (relatively) easily revert back to what it was.

I’ll give this a try and see how it goes.

One unsolicited plug: I use Red Gate’s SQL Prompt in SSMS. I can’t imaging having to work in SSMS without it. It’s pricey, but if you’re spending any time in SSMS, you should give it a try.

Connection Properties of External Data Ranges

Posted on September 25, 2015 by Dick Kusleika

I have a workbook with several connections to SQL Server. When I need to change the SQL statement, I do that in Connection Properties.

I added a command to the QAT to show the connection properties dialog, but there’s something I don’t like about it. If I’m in a table with a connection, it’s pretty likely that I want to see the properties of that particular connection and not just a list of all connections. Of course I’m awesome at naming my connections so I don’t have to guess which is which, but if you weren’t so awesome you might have trouble distinguishing them.

The long-term answer is to write my own interface to change the things I want to change. But in the mean time, I want to open the connections dialog and highlight the connection related to the table I’m in, if any.

Public Sub ShowConnection()
    
    Dim qt As QueryTable
    Dim sConName As String
    Dim i As Long
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        sConName = qt.WorkbookConnection.Name
        Application.CommandBars.ExecuteMso "Connections"
        
        Application.Wait Now + TimeSerial(0, 0, 2)
        
        For i = 1 To Len(sConName)
            SendKeys Mid$(sConName, i, 1)
        Next i
    Else
        Application.CommandBars.ExecuteMso "Connections"
    End If
    
End Sub

Public Sub ShowConnection()

Dim qt As QueryTable

Dim sConName As String

Dim i As Long

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

sConName = qt.WorkbookConnection.Name

Application.CommandBars.ExecuteMso "Connections"

Application.Wait Now + TimeSerial(0, 0, 2)

For i = 1 To Len(sConName)

SendKeys Mid$(sConName, i, 1)

Next i

Else

Application.CommandBars.ExecuteMso "Connections"

End If

End Sub

When I open the Connections dialog, I can start typing the name of the connection to get down to it. For example, I could start typing “dup” and it will highlight the first connection that starts with those keys.

With SendKeys, I can type the entire name. First I see if the ActiveCell is in a QueryTable. If it’s not, I just open the dialog. If it is, I open the dialog, wait a couple seconds, then send all the keys in the connection’s name. SendKeys can be very dangerous, but we’re just experimenting here.

What the above code actually does is open the Connections dialog, wait for it to close, then send all those keystrokes into the ActiveCell. Dangerous. And not helpful. Apparently the Connections dialog is modal and all code is suspended until it’s closed. I did a little searching and found this command, which does not help.

Application.CommandBars.ReleaseFocus

1	Application.CommandBars.ReleaseFocus

Maybe the old CommandBars behave differently than the Ribbon.

Application.CommandBars.FindControl(, 11205).Execute

1	Application.CommandBars.FindControl(, 11205).Execute

Nope. Same as ExecuteMso. One last try. This opens the dialog with SendKeys.

        sConName = qt.WorkbookConnection.Name
        SendKeys "%ao"
        
        Application.Wait Now + TimeSerial(0, 0, 2)
        
        For i = 1 To Len(sConName)
            SendKeys Mid$(sConName, i, 1)
        Next i

sConName = qt.WorkbookConnection.Name

SendKeys "%ao"

Application.Wait Now + TimeSerial(0, 0, 2)

For i = 1 To Len(sConName)

SendKeys Mid$(sConName, i, 1)

Next i

And it works. For some reason sending Alt+A+O opens the Connections dialog modeless, the SendKeys executes, and takes me to the “active” connection. I have a couple of applications on my machine that like to steal the focus, so I try to avoid SendKeys whenever I can (which is always). In this code, I’m using it twice, so I won’t be using it all. Interesting, though, that it seems to be the only way to get what I want.

Along the way, I discovered I could get to the “active” connection’s property sheet with this key sequence:

right-click key
b
a
tab
tab
enter

I guess that will work. It’s a lot of keystrokes, though.

MaxMinFair Rewrite

Posted on September 18, 2015 by Dick Kusleika

I read Charles William’s MaxMinFair algorithm and I didn’t like his approach. That’s typical. I’ll read somebody’s code and think “They’re making that too hard”. Then I’ll set about rewriting it. In this case, as in most cases, it turns out that it is that hard, but I wasn’t going to convince myself until I tried it. I ended up with a different approach that’s not shorter, not easier to read, and not easier to follow. Oh well, here it is anyway.

Function MaxMinFairDK(Supply As Double, Demands As Variant) As Variant
    
    Dim dPrior As Double
    Dim vaReturn As Variant
    Dim dAvailable As Double
    Dim i As Long, j As Long
    Dim dTemp As Double
    Dim wf As WorksheetFunction
    
    On Error GoTo ErrHandler
    Set wf = Application.WorksheetFunction
    If IsObject(Demands) Then Demands = Demands.Value2 'make range array
    dAvailable = Abs(Supply) 'ignore negative supplies
    
    If Not IsArray(Demands) Then
        'One demand = min of supply or demand
        MaxMinFairDK = Array(dAvailable, Demands)(Abs(dAvailable > Demands))
    Else
        'Excel returns NA when you use too many columns
        If UBound(Demands, 2) > 1 Then Err.Raise xlErrNA
        'Assume everybody gets everything they want
        ReDim vaReturn(LBound(Demands, 1) To UBound(Demands, 1), 1 To 1)
        vaReturn = Demands
        
        For i = UBound(Demands, 1) To LBound(Demands, 1) Step -1
            'If there's enough, do nothing except reduce what's available
            If dAvailable / i > (wf.Large(Demands, i) - dPrior) Then
                dAvailable = dAvailable - ((wf.Large(Demands, i) - dPrior) * i)
                dPrior = wf.Large(Demands, i)
            Else
                'Once there's not enough, everyone splits what's left
                For j = LBound(Demands, 1) To UBound(Demands, 1)
                    If Demands(j, 1) > dPrior Then
                        vaReturn(j, 1) = dPrior + (dAvailable / i)
                    End If
                Next j
                Exit For
            End If
        Next i
        
        MaxMinFairDK = vaReturn
    End If
    
ErrExit:
    Exit Function
    
ErrHandler:
    MaxMinFairDK = CVErr(Err.Number)
    Resume ErrExit
    
End Function

Function MaxMinFairDK(Supply As Double, Demands As Variant) As Variant

Dim dPrior As Double

Dim vaReturn As Variant

Dim dAvailable As Double

Dim i As Long, j As Long

Dim dTemp As Double

Dim wf As WorksheetFunction

On Error GoTo ErrHandler

Set wf = Application.WorksheetFunction

If IsObject(Demands) Then Demands = Demands.Value2 'make range array

dAvailable = Abs(Supply) 'ignore negative supplies

If Not IsArray(Demands) Then

'One demand = min of supply or demand

MaxMinFairDK = Array(dAvailable, Demands)(Abs(dAvailable > Demands))

Else

'Excel returns NA when you use too many columns

If UBound(Demands, 2) > 1 Then Err.Raise xlErrNA

'Assume everybody gets everything they want

ReDim vaReturn(LBound(Demands, 1) To UBound(Demands, 1), 1 To 1)

vaReturn = Demands

For i = UBound(Demands, 1) To LBound(Demands, 1) Step -1

'If there's enough, do nothing except reduce what's available

If dAvailable / i > (wf.Large(Demands, i) - dPrior) Then

dAvailable = dAvailable - ((wf.Large(Demands, i) - dPrior) * i)

dPrior = wf.Large(Demands, i)

Else

'Once there's not enough, everyone splits what's left

For j = LBound(Demands, 1) To UBound(Demands, 1)

If Demands(j, 1) > dPrior Then

vaReturn(j, 1) = dPrior + (dAvailable / i)

End If

Next j

Exit For

End If

Next i

MaxMinFairDK = vaReturn

End If

ErrExit:

Exit Function

ErrHandler:

MaxMinFairDK = CVErr(Err.Number)

Resume ErrExit

End Function

In Charles’s implementation, he allocates an equal amount of the supply to each node, then takes back what that node didn’t need and puts it back in the available pool. When I was looking at the results, I was thinking that the smallest n nodes simply get their demand and only when there’s not enough to go around do we need to do something different than allocate the full demand.

In my implementation, I start by giving everyone what they demand. Then I start with the smallest demand, and if I can accommodate that amount for everyone, I just reduce the amount available and move to the second smallest demand. At some point (the sixth smallest demand in Charles’s data) I can’t meet that demand and still give everyone an equal share. At that point, I give anyone who hasn’t had their demand met an equal amount – the amount that’s already been distributed plus an equal share of what’s left.

Rank	Demand	Incremental Demand	Allocated	Remaining
				18.30
7	0.70	0.70	4.90	13.40
6	1.00	0.30	1.80	11.60
5	1.30	0.30	1.50	10.10
4	2.00	0.70	2.80	7.30
3	3.50	1.50	4.50	2.80
2	7.40	3.90	7.80	(5.00)
1	10.00	2.60	2.60	(7.60)

In the first iteration, I hand out 0.70 to everyone because I have enough supply to do that. In the second iteration, I had out the differential, 0.30, to everyone who’s left because I have enough supply remaining. When I get to #2, I can’t hand out 3.90 to the remaining two nodes because I don’t have enough supply. I’ve allocated up to 3.5 to anyone who’s demanded it, so the last two get the 3.5 plus half of the 2.8 that remains.

Although I didn’t accomplish anything, it was still a fun exercise.

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Category: VBA

Unique Entries in Userform Dependent Listboxes

Cleaning Up My JoinRange Arguments

Anagrams and Palindromes

Retrieving Data from Add-in Worksheets

Announcing Excel Summit South: Auckland Sydney Melbourne in March 2016

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

EXTEND YOUR SKILLS

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

PROUDLY SUPPORTED BY

Editing SQL Statements in External Data Queries

Connection Properties of External Data Ranges

MaxMinFair Rewrite

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

EXTEND YOUR SKILLS

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015. Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

PROUDLY SUPPORTED BY

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.