Building a self-sorting list

September 03, 2010, 12:00 pm by Michael

I haven’t posted in a good while. I’ve done over half the Euler problems, but haven’t had the time to research the high-numbered ones considering I might even understand them. Now that I’ve retired from my second career, and my third is only part-time, maybe I’ll get back to it. Today is something perhaps more useful…to have a list of names, specifications, part numbers, etc and have them self-sort, de-duplicate, and collapse without ever having to go to the Sort Menu. Add a member to the bottom, and it flows through. Replace or paste over the data, and Excel turns the crank. Unique values appear, and no VBA is involved. This was a monthly chore in Job #2 for sometimes as many as 8000 email addresses.

Assume in Column A are 1000 (fantasy) names, in random order. These names were generated by using this website four times. Rice University and Dr. Chris Brown have provided name generation tools for many spoken languages. Your Column A might look something like this:

  A B
1 Alfred Sundagger =IF(LEN(A1)>0,COUNTIF(A:A,”<”&A1)+COUNTIF($A$1:$A1,”=”&A1),”")
2 Aki Stonesaber =IF(LEN(A2)>0,COUNTIF(A:A,”<”&A2)+COUNTIF($A$1:$A2,”=”&A2),”")
3 Yrre the Carver
4 Alfred Birchleaf
5 Olaf the Dagger
6 Isen Grimboldson
7 Eagle Arianson
8 Besyrwan Odonson
9 Onund Boarherder
10 Berdoi of the Radiant Face
11 Azhar Fahim
12 Osric the Hostler
13 Yasha the Hare
14 Warian Pikethrower
15 Konrad Firelash
16 Faran Stillstoke

 

The formula in B1 tests if there in anything of length in A1. I’ve found that the LEN() function always returns a value that agrees with my ol’ Mark 1 Mod 0 eyeballs, and empty text doesn’t mislead me. If there is something of length in A1, then COUNTIF() everything in A:A that is less than A1. This uses Excel’s lexicographic algorithms, and that opinion may differ from what you want, but I’ve never had a problem with it. Add to that count using mixed references the COUNTIF() of everything between $A$1 and $A1 inclusive that equals $A1. When we fill down this will become COUNTIF($A$1:$A2,”=”&A2) in A2. Otherwise, if there is nothing of length, place empty text (””-double double quotes). Fill down well below the extent of values in A:A.

Column B now looks something like this:

  A B C
1 Alfred Sundagger 43 =IF(ROW()<=COUNT(B:B),SMALL(B:B,ROW()),”")
2 Aki Stonesaber 25
3 Yrre the Carver 971
4 Alfred Birchleaf 39
5 Olaf the Dagger 660
6 Isen Grimboldson 470
7 Eagle Arianson 240
8 Besyrwan Odonson 144
9 Onund Boarherder 683
10 Berdoi of the Radiant Face 136
11 Azhar Fahim 110
12 Osric the Hostler 693
13 Yasha the Hare 960
14 Warian Pikethrower 944
15 Konrad Firelash 541
16 Faran Stillstoke 303

 

The formula in C1 tests if the row number is less than or equal to the count of the numbers in Column B. If it is, put the the smallest number there from Column B:B in ROW() order, otherwise put empty text. After filling down as far as in Column B, Column C is just 1 through the extent of your data in Column A. The use of SMALL() is what accommodates blank cells in A:A.

  A B C D
1 Alfred Sundagger 43 1 =IF(ROW()<=COUNT(B:B),INDEX(A:A,MATCH(C1,B:B,0),1),”")
2 Aki Stonesaber 25 2
3 Yrre the Carver 971 3
4 Alfred Birchleaf 39 4
5 Olaf the Dagger 660 5
6 Isen Grimboldson 470 6
7 Eagle Arianson 240 7
8 Besyrwan Odonson 144 8
9 Onund Boarherder 683 9
10 Berdoi of the Radiant Face 136 10
11 Azhar Fahim 110 11
12 Osric the Hostler 693 12
13 Yasha the Hare 960 13
14 Warian Pikethrower 944 14
15 Konrad Firelash 541 15
16 Faran Stillstoke 303 16

 

The formula in D1 tests the ROW() against the COUNT() again, and if ROW() is less than or equal to the COUNT(), specify zero as the third argument and find the exact MATCH() of the number in Column C:C within Column B:B, and then INDEX down Column A:A that far and return that result. Otherwise, put empty text. Fill down as far as in Columns B and C. After filling down, the list is sorted, and might look something like this:

  A B C D
1 Alfred Sundagger 43 1 Aart Moonhammer
2 Aki Stonesaber 25 2 Aart Moonhammer
3 Yrre the Carver 971 3 Aart the Millwright
4 Alfred Birchleaf 39 4 Aart Whiteson
5 Olaf the Dagger 660 5 Aberri of the White Heart
6 Isen Grimboldson 470 6 Aberri the Thieving Wizard
7 Eagle Arianson 240 7 Acennan Badgerrunner
8 Besyrwan Odonson 144 8 Acennan Kenricsson
9 Onund Boarherder 683 9 Adei of the Red Ruins
10 Berdoi of the Radiant Face 136 10 Adolphus Blackbird
11 Azhar Fahim 110 11 Adolphus Blackbird
12 Osric the Hostler 693 12 Adolphus Stillearth
13 Yasha the Hare 960 13 Adrik Yakovovich
14 Warian Pikethrower 944 14 Aethelred Awierganson
15 Konrad Firelash 541 15 Aethelred Darkseed
16 Faran Stillstoke 303 16 Ageio the Fastidious Sorceror

 

Next post we’ll de-dupe the list and then collapse it to unique entries.

…mrt

Category: General  |  8 Comments

Setting a Base Directory

September 02, 2010, 5:30 am by Dick Kusleika

If you want your Excel app to default to a specific directory when opening or saving files, see Changing the Current Directory. Be sure to read the comments.

I have a slightly different situation. I want my app to open to a specific directory that will give me easy access to sub directories. However, if the current directory is already a sub directory of my base directory, then it’s pretty likely to be in the one I want and I don’t want to change it. For example, my base directory is

S:\Flash\Payroll\

If I’m in S:\Flash\Payroll\2010\0824\", then that’s probably the directory I want and don’t want to change. However, if I’m in S:\Flash\Accounting\Reporting\, then I want to change to my base directory.

Public Sub SetFolderToPayroll()
   
    If InStr(1, CurDir, "S:\Flash\Payroll") = 0 Then
        ChDrive "S:"
        ChDir "S:\Flash\Payroll\"
    End If
   
End Sub

Pretty simple. If it’s at the base or a sub directory, don’t do anything. If it’s anything else, go to the base directory. Upon further reflection, though, it seems that a more general purpose procedure is in order.

Public Sub SetBaseDirectory(sBase As String)
   
    If Left$(CurDir, Len(sBase)) <> sBase Then
        ChDrive Left$(sBase, 2)
        ChDir sBase
    End If
   
End Sub

Now I can call it from multiple locations and pass in the base directory. If the left x characters is the base directory, don’t do anything. Otherwise, change the drive to the first two characters of sBase (e.g. “S:”) and change the directory to the base. It won’t work with UNC paths. Any other problems with it?

Category: File Operations  |  4 Comments

Count Active Customers

September 01, 2010, 5:30 am by Dick Kusleika

Jake wants to know, given an active date and an inactive date, how to count the customers that were active in a certain time period.

The ones we want are highlighted in yellow. The formula is

=COUNT(D2:D21)-SUMPRODUCT(($C$2:$C$21>=D25)+($D$2:$D$21< =C25))

It’s easier to figure out who is not active during that date range and subtract it from the total. The formula starts by counting everyone using the COUNT function. The SUMPRODUCT function is then subtracted from that. It gives the total of all the customers who became active after our End date plus the customers who became inactive before our Start date.

Note that this formula excludes the actual Start and End date. Customer 17 isn’t included because we’re really looking at 7/16/2010 to 7/24/2010. If you want the formula to be inclusive, simply change the <= and >= to < and >, respectively.

If you don’t like SUMPRODUCT, you can get there with COUNTIF

=COUNT(D2:D21)-(COUNTIF(C2:C21,">="&D25)+COUNTIF(D2:D21,"< ="&C25))

Sometimes it’s easier to turn the problem around and figure out who’s excluded.

Category: General  |  11 Comments

Dymo LabelWriter Part II

August 31, 2010, 5:30 am by Dick Kusleika

A couple of weeks ago, I posted some code to print labels on a Dymo LabelWriter 450. I wanted to post the finished code because it has a few more tricks in it.

Function PrintBoardFileLabel(ws As Worksheet) As Boolean

    Dim bReturn As Boolean
    Dim vaPrinters As Variant
    Dim i As Long
   
    Const sLABELFILE As String = "C:\BoardFile.label"
    Const sMSGNOFILE As String = "Label file not found at "
    Const sMSGNODYMO As String = "Dymo label printer not found."
   
    Const sSOURCE As String = "PrintBoardFileLabel()"
   
    On Error GoTo ErrorHandler
    bReturn = True

    If Len(Dir(sLABELFILE)) > 0 Then
        If mdyAddin Is Nothing Or mdyLabel Is Nothing Then
            CreateDymoObjects
        End If
       
        If Not mdyAddin Is Nothing Or Not mdyLabel Is Nothing Then
            vaPrinters = Split(mdyAddin.GetDymoPrinters, "|")
            For i = LBound(vaPrinters) To UBound(vaPrinters)
                If mdyAddin.IsPrinterOnline(vaPrinters(i)) Then
                    mdyAddin.SelectPrinter vaPrinters(i)
                    Exit For
                End If
            Next i
               
            mdyAddin.Open sLABELFILE
            mdyLabel.SetField "Text", ws.Range("rngComp1Serial").Value & " " & ws.Range("rngProdOrder").Value & _
                vbNewLine & StripItem(ws.Range("rngCustomer").Value) & " " & ws.Range("rngPO").Value
            mdyAddin.Print2 1, True, 1
        Else
            Err.Raise glHANDLED_ERROR, sSOURCE, sMSGNODYMO
        End If
   
    Else
        Err.Raise glHANDLED_ERROR, sSOURCE, sMSGNOFILE & sLABELFILE
    End If

ErrorExit:
    On Error Resume Next
    PrintBoardFileLabel = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

The procedure is now a function that returns a Boolean because I use the error logging scheme described in PED. But if you ignore all that stuff, there are a couple of changes worth noting.

First, I made the Dymo objects module level variables by putting this at the top of the module

Private mdyAddin As Object
Private mdyLabel As Object

and moved the creation of these variables into a separate procedure

Private Sub CreateDymoObjects()

    Set mdyAddin = CreateObject("Dymo.DymoAddin")
    Set mdyLabel = CreateObject("Dymo.DymoLabels")
       
End Sub

In addition to converting these to late-bound (using CreateObject and the Object variable type instead of setting a reference) so that it works well on different PCs, I needed to keep these objects live through the whole session. In the cases where multiple labels would be printed, I didn’t want to incur the overhead of creating and destroying the Dymo objects each time. The module level variables stay in scope until the add-in is closed and I check in my code whether they exist yet.

Another change I made was to find the proper printer. In my first iteration, I had one printer. So I used the GetDymoPrinters method with impunity. When I connected a second printer for testing, this no longer worked and I needed something more robust. The GetDymoPrinters returns a pipe (|) delimited string. This code

vaPrinters = Split(mdyAddin.GetDymoPrinters, "|")
For i = LBound(vaPrinters) To UBound(vaPrinters)
    If mdyAddin.IsPrinterOnline(vaPrinters(i)) Then
        mdyAddin.SelectPrinter vaPrinters(i)
        Exit For
    End If
Next i

splits the returned printer names into a Variant array. I then loop through that array and check the IsPrinterOnline property. When I find one that returns True, I use SelectPrinter to make it the “one” and exit the loop.

Almost all of the methods in the Dymo library return True or False indicating success or failure. I should have, but haven’t, written code like this

If mdyAddin.Open(sLABELFILE) Then

That would prevent errors if someone moves or renames the label file. Always build in some potential errors for job security (just kidding, don’t do that). Someday when I have some more time, I’ll tighten up the code further. But for now, it will have to do.

Category: Automation, Printing, VBA  |  Comment

Abbreviating Company Names

August 30, 2010, 9:12 am by Dick Kusleika

Last week I was creating file folder labels with my new Dymo LaserWriter 450. The information on the folder label is serial number, part number, company name, and purchase order. Normally, this works great. However, I ran into one on Friday with a 30 character part name and a 29 character company name. With shrink-to-fit, the font came out at about 4 points, surprisingly readable, but too small for these old eyes.

When we did this manually on our old label maker, we would abbreviate the company name and I wanted to replicate that in my code. It’s easy to do for humans. Less so for VBA. I started by removing all of the lower-case vowels.

General Electric -> Gnrl Elctrc

Not bad. Not, of course, how I would abbreviate it manually (GE), but not bad. By only removing lower case, I preserved the first letter and any initials that would seem to be key to deciphering the name. I still had names that were too long. I was trying to get them to 15 characters or less, and this method only got about half of them to less than that. Next, I removed Inc., LTD, Corporation, Corp and all that extraneous stuff that’s not critical to identifying the name. You have to be careful with case sensitivity or you can end up with

Principle Technologies, Inc. -> Prcpl Tchnlgs

because of the embedded “inc” in Principle.

Finally, I removed punctuation and got

Public Function RemoveVowels(sInput As String) As String

    Dim vaVowels As Variant
    Dim i As Long
    Dim sReturn As String

    sReturn = sInput
    vaVowels = Array("Corporation", "Corp", "Co.", " LTD", ".", ",", "-", "The ", " of", " and", " Inc", "a", "e", "i", "o", "u")

    For i = LBound(vaVowels) To UBound(vaVowels)
        sReturn = Replace$(sReturn, vaVowels(i), "", 1, , vbBinaryCompare)
    Next i

    sReturn = Replace$(sReturn, "  ", " ")

    RemoveVowels = Trim(sReturn)

End Function

If you implement something like this, you want to make sure that the longer terms come before the shorter ones. If you remove Corp before you remove Corporation, you’ll end up with “oration”, which doesn’t make any sense.

In the end, and a little to my surprise, this didn’t work very well. Looking at the transformed names, I was able to identify about 80% of them. That’s not very good, in my opinion. Then my co-worker suggested I use two lines on the file folder label. I smacked my forehead and did just that, and of course, it works beautifully. It was a fun exercise nonetheless.

Category: VBA Basics  |  7 Comments

Bushy Trees

August 27, 2010, 11:37 pm by Tushar Mehta

A favorite peeve of mine is code with “bushy trees.” I first saw this phrase in Kernighan and Plauger’s Elements of Programming Style.

Recently, I saw some code that checked if a RefEdit control referred to a single cell that contained a non negative integer. I cleaned up the formatting some since the original indentation style might be best described as “random tabs.” But, code formatting is not the subject of this post.

The IFs are fairly easy to understand since they essentially follow how most people would think to validate the string parameter. The tricky part comes in ensuring that one has the correct Else clause at the correct indentation level. In this case, that too might not be too difficult since the Else clauses are fairly trivial, each consisting of a single boolean assignment. But, imagine how much more difficult the task would be if there were further If clauses or loop structures in some of the Else clauses!

Option Explicit
Public Function getNonNegInt(aRefEditText As String, _
        ByRef Rslt As Integer) As Boolean
    Dim aRng As Range
    Const MaxInt As Integer = 32767
    getNonNegInt = True
    On Error Resume Next
    Set aRng = Range(aRefEditText)
    On Error GoTo 0
    If Not aRng Is Nothing Then
        If aRng.Cells.Count = 1 Then
            If IsNumeric(aRng.Value) Then
                If CDbl(aRng.Value) >= 0 Then
                    If CDbl(aRng.Value) = CLng(aRng.Value) Then
                        If CLng(aRng.Value) < = MaxInt Then
                            Rslt = CInt(aRng.Value)
                        Else
                            getNonNegInt = False
                            End If
                    Else
                        getNonNegInt = False
                        End If
                Else
                    getNonNegInt = False
                    End If
            Else
                getNonNegInt = False
                End If
        Else
            getNonNegInt = False
            End If
    Else
        getNonNegInt = False
        End If
    End Function

Code Sample 1

As a first pass, one could remove all the boolean assignments by first setting the function value to false and not to true as in Code Sample 1. Then only if we have an acceptable value do we return a True value.

Option Explicit
Public Function getNonNegInt(aRefEditText As String, _
        ByRef Rslt As Integer) As Boolean
    Dim aRng As Range
    Const MaxInt As Integer = 32767
    On Error Resume Next
    Set aRng = Range(aRefEditText)
    On Error GoTo 0
    getNonNegInt = False
    If Not aRng Is Nothing Then
        If aRng.Cells.Count = 1 Then
            If IsNumeric(aRng.Value) Then
                If CDbl(aRng.Value) >= 0 Then
                    If CDbl(aRng.Value) = CLng(aRng.Value) Then
                        If CLng(aRng.Value) < = MaxInt Then
                            Rslt = CInt(aRng.Value)
                            getNonNegInt = True
                           End If
                        End If
                    End If
                End If
            End If
        End If
    End Function

Code Sample 2

However, this still doesn’t help with all the nested If and End If clauses.

So, how does one clean up this deeply nested code? How about if we reverse the tests? Instead of testing if the range is not nothing, test if it is nothing. Instead of testing if the range contains 1 cell, test if it contains more than 1 cell. And, so on. The result as shown in Code Sample 3 is a single If statement (with multiple ElseIf clauses) that is ‘flat’ — with no confusing nesting!

Option Explicit

Public Function getNonNegInt(aRefEditText As String, _
        ByRef Rslt As Integer) As Boolean
    Dim aRng As Range
    Const MaxInt As Integer = 32767
    getNonNegInt = False
    On Error Resume Next
    Set aRng = Range(aRefEditText)
    On Error GoTo 0
    If aRng Is Nothing Then
    ElseIf aRng.Cells.Count > 1 Then
    ElseIf Not IsNumeric(aRng.Value) Then
    ElseIf CDbl(aRng.Value) < 0 Then
    ElseIf CDbl(aRng.Value) <> CLng(aRng.Value) Then
    ElseIf CLng(aRng.Value) > MaxInt Then
    Else
        Rslt = CInt(aRng.Value)
        getNonNegInt = True
        End If
    End Function

Code Sample 3

The code above uses a very powerful concept — that of a ‘null clause.’

In most cases, when we have a If…Then, we have some statement in the True branch of the If statement. It might be a series of assignments or it might be another If or a loop of some sort but there is something in the True branch. For example, in Code Sample 1 and Code Sample 2 above, there are two assignments.

                        If CLng(aRng.Value) < = MaxInt Then
                            Rslt = CInt(aRng.Value)
                            getNonNegInt = True
                           End If

However, in Code Sample 3, each Then is followed not by a statement but by the ElseIf clause. This results in a null statement (or empty block) in the True branch. This is perfectly legal in every programming language I’ve used and in this case it serves a very powerful role in simplifying the code.

For the sake of completeness, we will look at one more way of coding the above. In this particular scenario since there is no further processing after the string is validated, one could use use a series of Ifs that simply go to an exit point for bad data. But, this would not work for scenarios in which we wanted to do additional processing after the string of Ifs.

Option Explicit
Public Function getNonNegInt(aRefEditText As String, _
        ByRef Rslt As Integer) As Boolean
    Dim aRng As Range
    Const MaxInt As Integer = 32767
    On Error Resume Next
    Set aRng = Range(aRefEditText)
    On Error GoTo 0
    If aRng Is Nothing Then GoTo ErrXIT
    If aRng.Cells.Count > 1 Then GoTo ErrXIT
    If Not IsNumeric(aRng.Value) Then GoTo ErrXIT
    If CDbl(aRng.Value) < 0 Then GoTo ErrXIT
    If CDbl(aRng.Value) <> CLng(aRng.Value) Then GoTo ErrXIT
    If CLng(aRng.Value) > MaxInt Then GoTo ErrXIT
   
    Rslt = CInt(aRng.Value)
    getNonNegInt = True
    Exit Function
ErrXIT:
    getNonNegInt = False
    End Function

Code Sample 4

Category: CodeCritic, VBA Basics  |  26 Comments

A Hundred Thousand Name Managers!

August 19, 2010, 1:55 am by jkpieterse

Hi folks,

Many of the regulars here probably know the Name Manager utility, which Charles Williams and I created and give away for free on our websites.

Rumour has it this is one of best tools ever built for the Excel developer. I won’t argue with that!

Anyway, as I was looking at my web stats today I discovered a nice feat: We’ve just passed the 100,000 download count on the tool (this excludes the downloads from Charles’ site, so we can safely assume the true number is at least 50% more than that). Time for a celebration:

Hurray!

Regards,

Jan Karel Pieterse
www.jkp-ads.com

Category: Add-ins, Downloads, MVP, Names  |  17 Comments

Showing Hidden Sheet and Workbooks Dialog in VBA

August 12, 2010, 5:30 am by Dick Kusleika

A tip from Scott:

Windows - Unhide, from the menu, shows the Unhide dialog box for unhiding workbooks.

In vba, Application.Dialogs(xlDialogUnhide).Show gets the job done.

Where it gets tricky is unhiding worksheets. Via the menu, Format - Sheets - Unhide

In vba, the name of the dialog is not so intuitive.

Application.Dialogs(xlDialogWorkbookUnhide).Show

Poorly named, for sure, but you’ve been warned. Thanks Scott.

Category: General  |  10 Comments
« Previous Entries