Archive for the ‘VBA Advanced’ Category.

Putting together an Excel VBA course

Hi everyone!

I’m putting together an advanced VBA course and I am looking for feedback, as I plan to make this a top-notch training.
If you have a couple of minutes to spare (or perhaps are interested in attending an advanced VBA training in The Netherlands), please fill out my survey

Thank you in advance!

Regards,
Jan Karel Pieterse

A VBA performance class

Hi everyone!

If you write a lot of VBA code you probably sometimes run into performance issues. A customer rings you and complains that the Excel file you built for them does not perform well. I’ve written a small article on my site, inspired by a post here: Error Handling via an Error Class. I needed a quick way to log and report performance of subroutines and I also wanted to see how many times a routine was called.

See: A VBA performance class

Enjoy!

Jan Karel Pieterse
www.jkp-ads.com

An MSForms Treeview 2: Ready for beta testing

Hi everyone,

Some time ago I announced I was working on “An MSForms Treeview” replacing the Common Controls Treeview with an all-VBA counterpart.

This home-made treeview control will work on any Office version as of Office 2000, including 32 and 64 bit Office. I expect it will even work on MAC Office, but I’m still waiting for test results.

Peter Thornton (thank you Peter!) jumped in on the project enthusiastically and really made a difference adding all sorts of usefull stuff and optimising the code for performance.

Now we’re ready for beta testing.

Please visit this page of my website for a description of the control and a download file which includes a demo userform implementing the treeview classes we built:

An MSForms (all VBA) treeview

Tell us what you think of it (oh, and please report bugs too!).

Regards,

Jan Karel Pieterse
www.jkp-ads.com

An MSForms Treeview

If you have ever used the Treeview control from the “Additional controls” section, then you know what a versatile control this is to show hierarchically organized data.

There are a couple of problems with this Treeview control:

  1. Compile errors due to a difference in how the control libraries are registered in 32 bits Windows’ System32 and 64 bit Windows’ SysWOW32 folders. If you distribute a file that was saved in 64 bit Windows, containing one of the “Microsoft Windows Common Controls 6.0″ (The Treeview control is one of them) and with the reference set to “mscomctl.ocx”, people using 32 bit Windows will almost certainly have problems. At best it could entail removing both the control and the reference and replacing both, but at worst the user’s Excel can crash when trying to load the file and run the app.
  2. The standard Treeview control, like all non built-in ActiveX controls, cannot be used in 64 bit versions of Office.

Especially the second point convinced me it is time to develop a custom-made Treeview “control”, that only uses the native Office forms controls. I started building this a couple of weeks ago and after some time I tricked Peter Thornton into helping me with it :-)

The screenshot below shows both our new Treeview (left) and the Windows one (right) side-by-side:

Not bad, right?

Both Treeviews allow for checkboxes:

And both allow icons (windows Treeview not shown here):

You can also edit a node:

And expand and collapse nodes and navigate the tree using your arrow keys.

We built the custom Treeview using just two class modules. Using it in your project will require nothing more than copying the two classes and adding a bit of plumbing to your userform: some code and an empty frame which will hold the Treeview and possibly a frame with pictures for the icons.

We’re currently doing some cleaning up (like removing obsolete debugging stuff, adding comments and the like), so the “control” is not quite ready to be released to the outside world. Keep an eye on this blog, once we’re done we’ll post here.

Well, what do you think, is this useful or what? What functionality would be critical for you? Let us know!

Regards,

Jan Karel Pieterse

Excel 2013, SDI and modeless userforms

Hi Everyone,

With Excel 2013 we also got new document windowing in Excel; Microsoft decided to make Excel behave the same as Word:

from MDI:

Excel 2010 MDI interface showing two workbooks

The Excel 2010 MDI interface

to SDI:

Excel 2013 SDI interface showing two workbooks

The new SDI interface of Excel 2013

This causes havoc when one shows a modeless userform which should stay on top of all Excel windows:

Excel 2013 SDI can cause a userform to disappear

Excel 2013 SDI can cause a userform to disappear

I’ve devised a way to prevent this problem and written an article about how this was done.

Enjoy!

Regards,

Jan Karel Pieterse

www.jkp-ads.com

 

 

 

String Diffing

I’ve wanted to have some wiki-like diffing in my userform textboxes for a while now. Since I’ve been using wikis almost daily, I want the revisioning feature in everything I do. I’m not there yet, but I decided to see what kind of algorithm I would need to do it. I read the Wikipedia article on longest common subsequence and played around with it a little.

Public Function LCSTable(ByRef aOriginal() As String, ByRef aRevised() As String) As Variant
   
    Dim aReturn() As Long
    Dim i As Long, j As Long
   
    'aOriginal and aRevised should be 1-based.  Here we make a matrix with a gutter
    'row and column that will always be zero.
    ReDim aReturn(0 To UBound(aOriginal), 0 To UBound(aRevised))
   
    For i = 1 To UBound(aOriginal)
        For j = 1 To UBound(aRevised)
            'If the elements match, bump up the count from the element
            'one up and one left
            If aOriginal(i) = aRevised(j) Then
                aReturn(i, j) = aReturn(i - 1, j - 1) + 1
            Else
            'If they don't match, copy the largest from either above or from the left
                aReturn(i, j) = Application.WorksheetFunction.Max(aReturn(i, j - 1), aReturn(i - 1, j))
            End If
        Next j
    Next i
   
    LCSTable = aReturn
   
End Function

This code is called LCSLength in the article. It returns a matrix (2d array) with counts of matching elements at each position. For instance, if you’re diffing “Dick” and “Rick”, they have three letters in common and this table will compute that. It looks like this

R i c k
0 0 0 0 0
D 0 0 0 0 0
i 0 0 1 1 1
c 0 0 1 2 2
k 0 0 1 2 3

The rest of the functions use this table to figure out what’s what.

Public Function LCSString(ByRef vaTable As Variant, ByRef aOriginal() As String, ByRef aRevised() As String, ByVal i As Long, ByVal j As Long) As String
   
    Dim sReturn As String
   
    If i = 0 Or j = 0 Then
        sReturn = ""
    ElseIf aOriginal(i) = aRevised(j) Then
        sReturn = LCSString(vaTable, aOriginal, aRevised, i - 1, j - 1) & aOriginal(i)
    Else
        If vaTable(i, j - 1) > vaTable(i - 1, j) Then
            sReturn = LCSString(vaTable, aOriginal, aRevised, i, j - 1)
        Else
            sReturn = LCSString(vaTable, aOriginal, aRevised, i - 1, j)
        End If
    End If
   
    LCSString = sReturn
   
End Function

This function (called backtrack in the article) traces back through the table and outputs the longest common subsequence. It’s a recursive function (it calls itself) and continually appends letters (or other elements) on to the return string.

When both the i and j counters are zero, it stops calling itself. Otherwise, if the two letters match, it appends the current letter to the end and calls itself using the element up and to the left. If there’s no match, it goes to the larger of the element above (i-1) and the one to the left (j-1). By following the path of the larger numbers through the matrix, it can find the common letters. It’s originally called with the largest i and j – in the above table, it’s called looking at the 3 (the bottom right cell). Here’s how it tracks through the matrix (I’ll use cell references, but it’s not really cells).

  1. F6: k=k, so add k to the end of the string.
  2. E5: c=c, so add c to the end of the string.
  3. D4: i=i, so add i to the end of the string.
  4. C3: D <> R so find the larger of C2 or B3
  5. C2: i=0 so that’s it.
  6. Return “ick”

Thrilling, isn’t it?

Public Sub PrintDiff(ByRef vaTable As Variant, ByRef aOriginal() As String, ByRef aRevised() As String, ByVal i As Long, ByVal j As Long)
   
    If i > 0 Or j > 0 Then
        If i = 0 Then
            PrintDiff vaTable, aOriginal, aRevised, i, j - 1
            Debug.Print "+" & Space(1) & aRevised(j)
        ElseIf j = 0 Then
            PrintDiff vaTable, aOriginal, aRevised, i - 1, j
            Debug.Print "-" & Space(1) & aOriginal(i)
        Else
            If aOriginal(i) = aRevised(j) Then
                PrintDiff vaTable, aOriginal, aRevised, i - 1, j - 1
                Debug.Print Space(2) & aOriginal(i)
            ElseIf vaTable(i, j - 1) >= vaTable(i - 1, j) Then
                PrintDiff vaTable, aOriginal, aRevised, i, j - 1
                Debug.Print "+" & Space(1) & aRevised(j)
            ElseIf vaTable(i, j - 1) < vaTable(i - 1, j) Then
                PrintDiff vaTable, aOriginal, aRevised, i - 1, j
                Debug.Print "-" & Space(1) & aOriginal(i)
            Else
                Debug.Print
            End If
        End If
    End If
       
End Sub

This is another recursive function working backward through the matrix. When it finds a match, there’s no prefix. If it’s a new element (in Revised, but not Original) the prefix is a “+”. If it’s a deleted element, you get a “-“. This prints the results to the immediate window. Let’s look at some examples.

Public Sub DiffLetters()
   
    Dim sOriginal As String
    Dim sRevised As String
    Dim vaTable As Variant
    Dim i As Long
    Dim aOriginal() As String
    Dim aRevised() As String
   
    'Create strings
    sOriginal = "Richard J. Kusleika"
    sRevised = "Richard Kusleika Jr."
   
    'Make an array of letters
    ReDim aOriginal(1 To Len(sOriginal))
    For i = 1 To Len(sOriginal)
        aOriginal(i) = Mid$(sOriginal, i, 1)
    Next i
   
    ReDim aRevised(1 To Len(sRevised))
    For i = 1 To Len(sRevised)
        aRevised(i) = Mid$(sRevised, i, 1)
    Next i
   
    'Create the longest common sequence matrix
    vaTable = LCSTable(aOriginal, aRevised)
   
    'Print the longest common sequence
    Debug.Print LCSString(vaTable, aOriginal, aRevised, UBound(aOriginal), UBound(aRevised))
   
    'Show the diff between the letters
    PrintDiff vaTable, aOriginal, aRevised, UBound(aOriginal), UBound(aRevised)
   
End Sub

This shows the diff on a letter-by-letter basis.

The first line is a printout of the longest common subsequence. The rest is a letter-by-letter diff that shows which elements were added, deleted, and unchanged. We can also diff on words.

Public Sub DiffWords()
   
    Dim sOriginal As String
    Dim sRevised As String
    Dim aOriginal() As String
    Dim aRevised() As String
    Dim vaTable As Variant
   
    sOriginal = "Richard J. Kusleika"
    sRevised = "Richard Kusleika Jr."
   
    aOriginal = Split(Space(1) & sOriginal, Space(1))
    aRevised = Split(Space(1) & sRevised, Space(1))
   
    vaTable = LCSTable(aOriginal, aRevised)
   
    Debug.Print LCSString(vaTable, aOriginal, aRevised, UBound(aOriginal), UBound(aRevised))
   
    PrintDiff vaTable, aOriginal, aRevised, UBound(aOriginal), UBound(aRevised)
   
End Sub

Instead of filling the array with letters, I split the string on spaces to get words. Note that I put a leading space in front of each string before the split. The array needs to be 1-based and the Split function is zero based. The array doesn’t actually need to be 1-based, but the first row and column is ignored, so I made sure that it was something I didn’t care about. Once the arrays are filled, everything is the same.

Traditionally, diffing text is done line-by-line. So let’s do that. I found an example essay and made two files; OriginalDiff.txt and RevisedDiff.txt. I changed one thing in Revised and used this code to diff them.

Public Sub DiffLines()
   
    Dim sFile As String
    Dim lFile As Long
    Dim aOriginal() As String
    Dim aRevised() As String
    Dim lCnt As Long
    Dim vaTable As Variant
   
    sFile = Environ$("USERPROFILE") & "\Dropbox\Excel\OrignalDiff.txt"
    lFile = FreeFile
   
    Open sFile For Input As lFile
    Do While Not EOF(lFile)
        lCnt = lCnt + 1
        ReDim Preserve aOriginal(1 To lCnt)
        Line Input #lFile, aOriginal(lCnt)
    Loop
    Close lFile
   
    sFile = Environ$("USERPROFILE") & "\Dropbox\Excel\RevisedDiff.txt"
   
    lCnt = 0
    Open sFile For Input As lFile
    Do While Not EOF(lFile)
        lCnt = lCnt + 1
        ReDim Preserve aRevised(1 To lCnt)
        Line Input #lFile, aRevised(lCnt)
    Loop
    Close lFile
   
    vaTable = LCSTable(aOriginal, aRevised)
   
    PrintDiff vaTable, aOriginal, aRevised, UBound(aOriginal), UBound(aRevised)
   
End Sub

And that’s as far as I got. Next, I need to put the diffs into a database so I can display diffs and revert to prior versions. Or, quite possibly, I’ll lose interest because I don’t have a burning need for this. It’s just something I’ve wanted to do.

You can download Diffing.zip

In an userform list all available fonts

The motivation for this tip was to share how to

1) dynamically add controls to a userform
2) respond to events for these controls, and
3) specifically respond to events using a callback procedure that is located in another class module!

Since this may come across as a fairly technical topic, this tip utilizes the above capabilities to provide a functional solution:

1) list in an userform the names of all available fonts with each name shown using that font,
2) hover over the option button associated with a font to see a sample of every English keyboard character in that font,
3) click on the option button to select the font, and, finally,
4) use this capability to programmatically get the user’s selection, if any.

Below is an example of the font selector in action. Each OptionButton shows the name of one available font using the font itself. At the same time, the control tool tip shows the font name in English (see the Wide Latin tip). A sample of how every keyboard character will look in that font appears below the font selector frame.

The motivation for this example was a Daily Dose of Excel blog post by Michael (http://www.dailydoseofexcel.com/archives/2012/03/14/getting-a-font-list-to-a-combo-box-2/). He used a combo box to list the fonts available to Excel leveraging a technique shown in a tip by John Walkenbach (http://www.j-walk.com/ss/excel/tips/tip79.htm).

For a version in a page by itself (i.e., not in a scrollable iframe as below) visit http://www.tushar-mehta.com/publish_train/xl_vba_cases/1054%20show%20fonts%20in%20userform.shtml

Tushar Mehta

Populating Class Properties

Depending on the requirements, I’ll choose a method for populating my custom collection classes using from data from a worksheet.

In this example, I’m using a list of the best selling albums of all time.

My Album class has properties as follows:

Public Artist As String
Public Album As String
Public Released As Date
Public Genre As String
Public Sales As Long

The code in my main routine is:

Sub test()
    Dim albs As Albums, alb As Album
 
    Set albs = New Albums
    albs.FillFromSheet Sheet1
End Sub

Filling the collection is just a matter of reading each row and popping the contained values into the right property.
The difficulty is knowing which columns relate to what properties. It’s a mapping problem – mapping columns to properties.

I could make an assumption about the positions of the columns and assume each is a known index.

Public Sub FillFromSheet(wks As Worksheet)
    Const cFirstRow = 2
    Dim i As Long, obj As Album
 
    With wks
        For i = cFirstRow To .Cells(Rows.Count, 1).End(xlUp).Row
            Set obj = New Album
            obj.Artist = .Cells(i, 1)
            obj.Album = .Cells(i, 2)
            obj.Released = .Cells(i, 3)
            obj.Genre = .Cells(i, 4)
            obj.Sales = .Cells(i, 5)
 
            Me.Add obj
        Next
    End With
End Sub

I don’t really like this because I’ve been taught and have tried to follow the approach that offsets/indices like these should be defined as constants.
I’ll modify my FillFromSheet code.

Const cArtistCol = 1, cAlbumCol = 2, cReleasedCol = 3, cGenreCol = 4, cSalesCol = 5
...
    obj.Artist = .Cells(i, cArtistCol)
    obj.Album = .Cells(i, cAlbumCol)
    obj.Released = .Cells(i, cReleasedCol)
    obj.Genre = .Cells(i, cGenreCol)
    obj.Sales = .Cells(i, cSalesCol)

Seems roughly better, but this too has problems. It can be a pain when you want to change the column order or insert a new column.
You’d have to go through the code and update all of the numbers.
While this is ok for 5, as I have here, changing out 50 columns is a chore.

So, I use an Enum block to determine column positions.
At the top of the class module:

Private Enum AlbumCols
    Artist = 1  ' =1 is necessary, otherwise Enum starts at zero
     Album
    Released
    Genre
    Sales
End Enum

And another modification to my FillFromSheet code:

    obj.Artist = .Cells(i, AlbumCols.Artist)
    obj.Album = .Cells(i, AlbumCols.Album)
    obj.Released = .Cells(i, AlbumCols.Released)
    obj.Genre = .Cells(i, AlbumCols.Genre)
    obj.Sales = .Cells(i, AlbumCols.Sales)

That works well. If I rearrange my columns on the worksheet, the only code change needed is a swap of items in the Enum block – a painless and quick update!

But that’s only if the changes to column order are in my control.
What if an end user changes the column order? Do I really want them poking around in my Enum code too?
I’d usually stop now and decide that if the end user starts screwing with column positions, it’s fair enough that the code should break.
However, if I wanted to go the extra mile, I’d have to find the column index by searching for the text in the column headers.

Excel 2007 (and 2003 to an extent) has a feature called Tables, otherwise known as ListObjects.

My code in the main routine changes to:

Set albs = New Albums
albs.FillFromTable Sheet1.ListObjects("Best_Selling_Albums")

… and the code in my collection class is:

Public Sub FillFromTable(tbl As ListObject)
    Const cArtistCol = "Artist", cAlbumCol = "Album", cReleasedCol = "Released"
    Const cGenreCol = "Genre", cSalesCol = "Sales (millions)"
 
    Dim i As Long, obj As Album, row As ListRow, col As New Collection
 
    With tbl.HeaderRowRange: For i = 1 To .Count: col.Add i, .Columns(i): Next: End With
 
    For Each row In tbl.ListRows
        Set obj = New Album
        obj.Artist = row.Range(, col(cArtistCol))
        obj.Album = row.Range(, col(cAlbumCol))
        obj.Released = row.Range(, col(cReleasedCol))
        obj.Genre = row.Range(, col(cGenreCol))
        obj.Sales = row.Range(, col(cSalesCol))
 
        Me.Add obj
    Next
End Sub

In the preceding code I created a collection of key-value pairs. The key is the column label, the value is column index.
I use that as a lookup when populating my properties.

That’s just a few approaches to reading a table of values into a collection.
I’m interested in feedback. How do you map column positions to properties?