Copy Unique Values

Posted on May 25, 2012 by Rob van Gelder

One of the more frequent activities I perform is taking a list and extracting unique values as a seperate list.

The way to do this is long and stupid.
In Excel 2003 you select your range, go to the Data menu, Filter menu, select Advanced Filter. Select “Copy to another location”, tick “Unique records only”, then put a range in the “Copy To” box.
In Excel 2007 and above, it’s one less click. Go to the Data ribbon, from the Sort & Filter group click Advanced, then the same Advanced Filter window appears as Excel 2003.

Sick of this, a few years ago I wrote a macro to extract Unique Values, which worked so-so. My macro had minor issues that I could never really be bothered fixing, but it was miles better than trekking through those menus.
Fast forward to a couple of weeks ago and I lost my macro, somehow, which is disappointing, but it was buggy anyway, but I still wanted an easy way to extract unique values and I didn’t want to write the macro again.
It suddenly occurred to me that the same method of hitting shortcuts keys for paste values (alt, e, s, v) could be applied to copying unique values.

Here’s what I do:
Select the range I want to extract from
Hold down the Alt key
Press these keys in sequence: d, f, a, r, o, t
Release the Alt key
Select the range to paste the unique values to

It’s even possible to create a vba macro for this:
SendKeys "%(dfarot)"

Now, to train my muscle memory to type dfarot naturally…

Copy Chart as a Picture

Posted on May 5, 2012 by Rob van Gelder

I needed to copy a chart to a picture, but I wanted it to be an enhanced metafile (EMF) which is kind of like a vector graphic picture format. EMF graphics scale well when the page resizes.

A user would select the chart, run the macro and a dialog would ask them where to save the picture to – pretty simple, but handy!
It uses the clipboard to do the conversion.

Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Declare Function CloseClipboard Lib "user32" () As Long Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Declare Function EmptyClipboard Lib "user32" () As Long Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long


Const CF_ENHMETAFILE As Long = 14

Const cInitialFilename = "Picture1.emf"

Const cFileFilter = "Enhanced Windows Metafile (*.emf), *.emf"
Public Sub SaveAsEMF()

    Dim var As Variant, lng As Long
    var = Application.GetSaveAsFilename(cInitialFilename, cFileFilter)

    If VarType(var) <> vbBoolean Then

        On Error Resume Next

        Selection.Copy

OpenClipboard 0 lng = GetClipboardData(CF_ENHMETAFILE) lng = CopyEnhMetaFileA(lng, var) EmptyClipboard CloseClipboard DeleteEnhMetaFile lng On Error GoTo 0 End If End Sub

Populating Class Properties

Posted on December 26, 2011January 27, 2017 by Rob van Gelder

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

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

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

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

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)

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

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)

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")

1 2	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

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

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?

Sorting a Custom Collection Class

Posted on October 31, 2011March 1, 2017 by Rob van Gelder

I’ve been following Dick’s VBHelpers Build series (1, 2, 3) and his last post reminded me that, from time to time, I need to sort a collection of items in-memory.

I don’t have to sort all that often, so my approach has changed over time. I’ve kind of settled on the following.

Let’s say I have a People collection that contains Person items.

In my Person class I’ve written a method (Function) called CompareTo. It works a lot like VBA’s StrComp, returning -1, 0 or +1 depending on whether Item 1 is less than or greater than Item 2.

I’d use it against two person items: person1.CompareTo person2

Public Function CompareTo(per As Person) As Long
    Dim i As Long
 
    If Me.LastName = per.LastName Then
        If Me.FirstName = per.FirstName Then
            i = 0
        ElseIf Me.FirstName < per.FirstName Then
            i = -1
        Else
            i = 1
        End If
    ElseIf Me.LastName < per.LastName Then
        i = -1
    Else
        i = 1
    End If
 
    CompareTo = i
    
End Function

Public Function CompareTo(per As Person) As Long

Dim i As Long

If Me.LastName = per.LastName Then

If Me.FirstName = per.FirstName Then

i = 0

ElseIf Me.FirstName < per.FirstName Then

i = -1

Else

i = 1

End If

ElseIf Me.LastName < per.LastName Then

i = -1

Else

i = 1

End If

CompareTo = i

End Function

In my People collection class, I’ve created a method called Sort that returns itself in sorted order.

It’s an Insertion Sort that I converted from Wikipedia’s article into VBA. Notice how it uses the CompareTo method for deciding on item placement.

Public Function Sort() As People
    Dim i As Long, j As Long, k As Long, bln As Boolean
    Dim lngCount As Long, arr() As Long, ppl As People
    lngCount = Me.Count
    If lngCount > 0 Then
        ReDim arr(0 To lngCount - 1)
        For i = 0 To lngCount - 1: arr(i) = i + 1: Next

        For i = 1 To lngCount - 1
            k = arr(i)
            j = i - 1
            bln = False
            Do
                If Me(arr(j)).CompareTo(Me(k)) > 0 Then
                    arr(j + 1) = arr(j)
                    j = j - 1
                    If j < 0 Then bln = True
                Else
                    bln = True
                End If
            Loop Until bln
            arr(j + 1) = k
        Next
    End If

    Set ppl = New People
    For i = 0 To lngCount - 1: ppl.Add Me(arr(i)): Next

    Set Sort = ppl
End Function

Public Function Sort() As People

Dim i As Long, j As Long, k As Long, bln As Boolean

Dim lngCount As Long, arr() As Long, ppl As People

lngCount = Me.Count

If lngCount > 0 Then

ReDim arr(0 To lngCount - 1)

For i = 0 To lngCount - 1: arr(i) = i + 1: Next

For i = 1 To lngCount - 1

k = arr(i)

j = i - 1

bln = False

If Me(arr(j)).CompareTo(Me(k)) > 0 Then

arr(j + 1) = arr(j)

j = j - 1

If j < 0 Then bln = True

Else

bln = True

End If

Loop Until bln

arr(j + 1) = k

End If

Set ppl = New People

For i = 0 To lngCount - 1: ppl.Add Me(arr(i)): Next

Set Sort = ppl

End Function

Now I get to use the above in my main code routines:

Sub test3()
    Dim ppl As People, per As Person
    Set ppl = New People
    ppl.FillFromSheet ActiveSheet

    For Each per In ppl.Sort
        Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.Gender.ToString; vbTab; per.City
    Next
End Sub

Sub test3()

Dim ppl As People, per As Person

Set ppl = New People

ppl.FillFromSheet ActiveSheet

For Each per In ppl.Sort

Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.Gender.ToString; vbTab; per.City

End Sub

The code above is available for download. It’s an extension of the code I posted a year ago on the same topic (links 1, 2). It also includes the Enum enhancements suggested by Andy Pope way back then.

You can download SortClass.zip

Good Row Bad Row

Posted on July 28, 2010 by Rob van Gelder

In the office, I sometimes deal with a table of values. In that table, there are good rows, and bad rows.
I want to quickly put the good rows to the top of the table, and leave the bad rows at the bottom of the table.

So I take the first unused column, give it a rubbish column header, such as “qwe”, and build a formula in the next row down ready to autofill.
The formula will return TRUE for the goodies, and FALSE for the baddies.
After an autofill, I’ll sort descending by that column, which puts the goodies at the top.
Usually the formula will be something simple, like

=TRIM(A2)=A2

In that way, all of the bad rows can be dealt with as a group, rather than scanning through the rows fixing one at a time.

There’s another one I regularly do. It’s “is this value in my other list”. Kind of like an integrity check.
I’ll have two tables – a primary table and a secondary table. I need to know if rows in my primary table are linked to rows in my secondary table.
For example, Employee not in Attendees list. Purchase Order not in Invoices list.
I’ll build a column on the side of the primary table that returns either TRUE or FALSE and use a lookup formula to do the work.
Once I have a column of TRUEs and FALSEs, it’s a simple matter to sort, then focus on the baddies.

In fact, I do these types of yes/no lookups so often that I remember the pattern to building the formula off by heart. Sad, but true.

1. NOT followed by ISNA followed by MATCH

=NOT(ISNA(MATCH(

2. Value to look up

A1,

3. List to look up

B3:B9,

4. 0 for exact match

5. three closing brackets

)))

6. Highlight the “list to look up” text and hit the F4 key to make it absolute.

=NOT(ISNA(MATCH(A1, $B$3:$B$9, 0)))

Now that I think about it, I’ve probably typed that line of text over 1000 times and I really should write a macro for that.

While I’m writing about the lookup, here’s a way of doing a lookup all without an external list.
It’s possible to bring, for example, B3:B9 into the formula while still retaining the MATCH function – what I call an inline lookup.
Simply highlight the B3:B9 text, and press F9 on your keyboard.
By pressing F9, it brings the list into your formula as an array.

=NOT(ISNA(MATCH(A1, {“Apple”;”Banana”;”Orange”;”Strawberry”;”Grape”;”Mango”;”Lemon”}, 0)))

goodrowbadrow

Usually you’ll want to leave the list as a range of its own, but depending on the occasion, it could be tidier to have it inline.

Class Property Fixed Values

Posted on July 8, 2010January 27, 2017 by Rob van Gelder

In my previous post on a Custom Collection Class, I used an example of a People collection with Person items.

As well as First Name, Last Name, and City, I had originally included the Gender property (Female, Male, Unknown), but removed it just prior to posting. I purposely left it out because I didn’t want to distract from the core topic (collection classes), and because I have a special way of dealing with properties of this type.

I could have just defined Gender as a String datatype.

Public Gender as String

1	Public Gender as String

That would work.

We could be a little more rigid with our variable, and define an Enum.

Public Enum GenderEnum
    Unknown
    Female
    Male
End Enum
…
Public Gender as GenderEnum

Public Enum GenderEnum

Unknown

Female

Male

End Enum

…

Public Gender as GenderEnum

It’s an OK approach, though it has a couple of small issues.

I can set Gender to numbers other than the Enums 0, 1, and 2. MyPerson.Gender = 7 will not error.
The required helper functions GenderEnumToString, and the StringToGenderEnum are stored in a separate place to the Gender variable, probably buried in a giant module. While it’s improbable that there will be more than 2 genders, your property might grow over time. It’s nice to have related code all in the same place.

What follows is a different approach that mixes Classes with Enums. You get the validation capability of a Class property, the Intellisense of an Enum, and related code living in the same place.

You get code that reads like

 per.Gender = Male
    per.Gender.FromString “Woman”
    Debug.Print per.Gender.ToString()

per.Gender = Male

per.Gender.FromString “Woman”

Debug.Print per.Gender.ToString()

This example starts where the Custom Collection Class post ends. It is assumed you have the same example ready to use.

As in the first post, we’ll persevere with the VBA Attribute workaround. Copy the following code to Notepad, save as Gender.cls, then use VBA to Import the file. Did you know that instead of clicking File > Import, you can drag’n’drop the file from Windows Explorer to the Project window?

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
End
Attribute VB_Name = "Gender"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public Enum GenderEnum
    Unknown
    Female
    Male
End Enum

Private Const LoLimit = GenderEnum.Unknown
Private Const HiLimit = GenderEnum.Male

Private gen As GenderEnum

Private Sub Class_Initialize()
    gen = GenderEnum.Unknown
End Sub

Public Property Get Value() As GenderEnum
Attribute Item.VB_UserMemId = 0
    Value = gen
End Property

Public Property Let Value(val As GenderEnum)
    If val >= LoLimit And val <= HiLimit Then
        gen = val
    Else
        Err.Raise Number:=vbObjectError + 513, Description:="Invalid value for Gender"
    End If
End Property

Public Sub FromString(str As String)
    Select Case Trim(LCase(str))
        Case "f", "Female", "w", "woman": Me.Value = GenderEnum.Female
        Case "m", "Male", "man": Me.Value = GenderEnum.Male
        Case Else: Me.Value = GenderEnum.Unknown
    End Select
End Sub

Public Function ToString() As String
    Dim str As String

    Select Case gen
        Case GenderEnum.Female: str = "Female"
        Case GenderEnum.Male: str = "Male"
        Case Else: str = "Unknown"
    End Select
    ToString = str
End Function

VERSION 1.0 CLASS

BEGIN

MultiUse = -1 'True

End

Attribute VB_Name = "Gender"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = False

Attribute VB_Exposed = False

Option Explicit

Public Enum GenderEnum

Unknown

Female

Male

End Enum

Private Const LoLimit = GenderEnum.Unknown

Private Const HiLimit = GenderEnum.Male

Private gen As GenderEnum

Private Sub Class_Initialize()

gen = GenderEnum.Unknown

End Sub

Public Property Get Value() As GenderEnum

Attribute Item.VB_UserMemId = 0

Value = gen

End Property

Public Property Let Value(val As GenderEnum)

If val >= LoLimit And val <= HiLimit Then

gen = val

Else

Err.Raise Number:=vbObjectError + 513, Description:="Invalid value for Gender"

End If

End Property

Public Sub FromString(str As String)

Select Case Trim(LCase(str))

Case "f", "Female", "w", "woman": Me.Value = GenderEnum.Female

Case "m", "Male", "man": Me.Value = GenderEnum.Male

Case Else: Me.Value = GenderEnum.Unknown

End Select

End Sub

Public Function ToString() As String

Dim str As String

Select Case gen

Case GenderEnum.Female: str = "Female"

Case GenderEnum.Male: str = "Male"

Case Else: str = "Unknown"

End Select

ToString = str

End Function

Notice in the code above the line that reads: Attribute Value.VB_UserMemId = 0. That line is the one thing that makes us perform the Notepad workaround, but it is pretty important that we do it. The Attribute tells VBA the Value property is the Default property for the Class. For further reading, take a look at Chip Pearson’s explainer of the feature.

There’s also a couple of Consts defining the valid range of Gender values allowed: LoLimit and HiLimit. As a Gender value is assigned, validation is performed against these Consts through Property Let Value.

Now we can add our Gender property to the Person class. The Person class should now look as follows:

Public FirstName As String
Public LastName As String
Public City As String
Public Gender As Gender
Private Sub Class_Initialize()
    Set Me.Gender = New Gender
End Sub

Public FirstName As String

Public LastName As String

Public City As String

Public Gender As Gender

Private Sub Class_Initialize()

Set Me.Gender = New Gender

End Sub

Great! Now we’re ready to test it.

Sub test()
    Dim per As Person
    Set per = New Person
    'Test 1: set the gender to a value
    per.Gender = Male
    Debug.Print per.Gender.ToString()

    'Test 2: Take a string, and store the Gender
    per.Gender.FromString “Woman”
    Debug.Print per.Gender.ToString()

    'Test 3: supply an invalid value – get an error
    On Error Resume Next
    per.Gender = 7
    Debug.Print Err.Description
End Sub

Sub test()

Dim per As Person

Set per = New Person

'Test 1: set the gender to a value

per.Gender = Male

Debug.Print per.Gender.ToString()

'Test 2: Take a string, and store the Gender

per.Gender.FromString “Woman”

Debug.Print per.Gender.ToString()

'Test 3: supply an invalid value – get an error

On Error Resume Next

per.Gender = 7

Debug.Print Err.Description

End Sub

I’ve put together a workbook containing the code of this post, and also the code of my previous post.

You can download Gender_Class.zip

Custom Collection Class

Posted on July 4, 2010February 17, 2018 by Rob van Gelder

When I first started programming in Excel VBA, I had problems using Class modules. I had done plenty of reading on Object Oriented programming, but I just didn’t understand the attraction. Years of programming in assembly language had wired my brain in a way incompatible with OO and every time I tried to use Classes and Collections, I quickly became frustrated and reverted back to my old ways.

My ways consisted of modules of Functions, and managing “lists of things” using Arrays and User Defined Types.

I suppose it had to happen at some time, but eventually it all clicked and now I want to use this approach for every programming assignment I take on.

For this article, we’re going to create a collection of People, and write code dealing with those people.

Start off with a blank workbook, and add a 3 column list of people: First Name, Last Name, City.
I used Dick’s Generate Sample Data add-in to build a list of 50 people.
I copy-pasted the first 10 cities against the remaining rows just so there are many people for any one city.
Later on in the post I’ve made an assumption that the list contents start on row 2 so please construct your layout so it appears like the screenshot.

customcollectionclass_1

Add a Class Module called Person.
Copy-Paste the following code in:

Option Explicit

Public FirstName As String
Public LastName As String
Public City As String

Option Explicit

Public FirstName As String

Public LastName As String

Public City As String

The next step is to add a Custom Collection Class. It’s really just a wrapper around the built-in Collection class. I use this as a Template, and search-replace Person / People.
I wish it were as easy as dropping the code into a new Class module, but you’ll need to do this little workaround instead.
You see, we need a few Attribute modifiers to alter the behaviour of two important properties, and it’s not possible to edit Attribute modifiers from VBA’s User Interface.
If you didn’t attach the Attribute modifiers, the Item property would not be the default property, and you would lose the ability to For Each / Next on the Collection.

So, using Notepad, save the following code as People.cls, then from VBA > File > Import File, and import People.cls.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
End
Attribute VB_Name = "People"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private objPeople As Collection

Private Sub Class_Initialize()
    Set objPeople = New Collection
End Sub

Private Sub Class_Terminate()
    Set objPeople = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = objPeople.[_NewEnum]
End Property

Public Sub Add(obj As Person)
    objPeople.Add obj
End Sub

Public Sub Remove(Index As Variant)
    objPeople.Remove Index
End Sub

Public Property Get Item(Index As Variant) As Person
Attribute Item.VB_UserMemId = 0
    Set Item = objPeople.Item(Index)
End Property

Property Get Count() As Long
    Count = objPeople.Count
End Property

Public Sub Clear()
    Set objPeople = New Collection
End Sub

VERSION 1.0 CLASS

BEGIN

MultiUse = -1 'True

End

Attribute VB_Name = "People"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = False

Attribute VB_Exposed = False

Option Explicit

Private objPeople As Collection

Private Sub Class_Initialize()

Set objPeople = New Collection

End Sub

Private Sub Class_Terminate()

Set objPeople = Nothing

End Sub

Public Property Get NewEnum() As IUnknown

Attribute NewEnum.VB_UserMemId = -4

Attribute NewEnum.VB_MemberFlags = "40"

Set NewEnum = objPeople.[_NewEnum]

End Property

Public Sub Add(obj As Person)

objPeople.Add obj

End Sub

Public Sub Remove(Index As Variant)

objPeople.Remove Index

End Sub

Public Property Get Item(Index As Variant) As Person

Attribute Item.VB_UserMemId = 0

Set Item = objPeople.Item(Index)

End Property

Property Get Count() As Long

Count = objPeople.Count

End Property

Public Sub Clear()

Set objPeople = New Collection

End Sub

We’ll need a way of filling the Collection. I like adding a method to the Collection class called FillFromXYZ where XYZ could be a Sheet, or a Database, or an XML source, or anything really.
Add this code to the end of the People class

Public Sub FillFromSheet(wks As Worksheet)
    Const cFirstRow = 2, cFirstNameCol = 1, cLastNameCol = 2, cCityCol = 3
    Dim i As Long, obj As Person
    With wks
        For i = cFirstRow To .Cells(Rows.Count, 1).End(xlUp).Row
            Set obj = New Person
            obj.FirstName = .Cells(i, cFirstNameCol)
            obj.LastName = .Cells(i, cLastNameCol)
            obj.City = .Cells(i, cCityCol)

            Me.Add obj
        Next
    End With
End Sub

Public Sub FillFromSheet(wks As Worksheet)

Const cFirstRow = 2, cFirstNameCol = 1, cLastNameCol = 2, cCityCol = 3

Dim i As Long, obj As Person

With wks

For i = cFirstRow To .Cells(Rows.Count, 1).End(xlUp).Row

Set obj = New Person

obj.FirstName = .Cells(i, cFirstNameCol)

obj.LastName = .Cells(i, cLastNameCol)

obj.City = .Cells(i, cCityCol)

Me.Add obj

End With

End Sub

Great! We’ve got all the ingredients readied for some testing.

We can loop through all of items in a list using For Each / Next
Insert a new Standard Module, and copy-paste this code in, then run it.

Sub test()
    Dim ppl As People, per As Person
    Set ppl = New People
    ppl.FillFromSheet ActiveSheet

    Debug.Print "Test 1: return all People"
    For Each per In ppl
        Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City
    Next
End Sub

Sub test()

Dim ppl As People, per As Person

Set ppl = New People

ppl.FillFromSheet ActiveSheet

Debug.Print "Test 1: return all People"

For Each per In ppl

Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City

End Sub

We can select a specific item in the list, accessed by Index number

    Debug.Print "Test 2: return a single Person"
    Debug.Print ppl(2).FirstName; vbTab; ppl(2).LastName; vbTab; ppl(2).City

1 2	Debug.Print "Test 2: return a single Person" Debug.Print ppl(2).FirstName; vbTab; ppl(2).LastName; vbTab; ppl(2).City

We can filter the list by criteria
Add this code to the end of the People class …

Public Function FilterByCity(str As String) As People
    Dim ppl As People, per As Person
    Set ppl = New People

    For Each per In Me
        If per.City = str Then ppl.Add per
    Next

    Set FilterByCity = ppl
End Function

Public Function FilterByCity(str As String) As People

Dim ppl As People, per As Person

Set ppl = New People

For Each per In Me

If per.City = str Then ppl.Add per

Set FilterByCity = ppl

End Function

… then run Test 3

    Debug.Print "Test 3: return all People of a specific City"
    For Each per In ppl.FilterByCity("New York")
        Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City
    Next

Debug.Print "Test 3: return all People of a specific City"

For Each per In ppl.FilterByCity("New York")

Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City

I suppose the thing I like the most about custom collection classes is the ability to do Method Chaining (methods of a collection that return a collection of the same class)

Here’s how we can link Filter methods together.
Add this code to the end of the People class …

Public Function FilterByLastNameLike(str As String) As People
    Dim ppl As People, per As Person
    Set ppl = New People

    For Each per In Me
        If per.LastName Like str Then ppl.Add per
    Next

    Set FilterByLastNameLike = ppl
End Function

Public Function FilterByLastNameLike(str As String) As People

Dim ppl As People, per As Person

Set ppl = New People

For Each per In Me

If per.LastName Like str Then ppl.Add per

Set FilterByLastNameLike = ppl

End Function

… then run Test 4

    Debug.Print "Test 4: return all People of a specific city and similar name"
    For Each per In ppl.FilterByCity("Athens").FilterByLastNameLike("*h*")
        Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City
    Next

Debug.Print "Test 4: return all People of a specific city and similar name"

For Each per In ppl.FilterByCity("Athens").FilterByLastNameLike("*h*")

Debug.Print per.FirstName; vbTab; per.LastName; vbTab; per.City

We could go further with options like adding an OrderBy function:

For Each per In ppl.FilterByCity("Athens").FilterByLastNameLike("*h*").OrderByLastName

1	For Each per In ppl.FilterByCity("Athens").FilterByLastNameLike("h").OrderByLastName

or returning arrays, or lists of unique entries

str() = ppl.FilterByLastNameLike("*h*").UniqueCities

1	str() = ppl.FilterByLastNameLike("h").UniqueCities

By using Custom Collection Classes, it allows me to program against lists within the comfort of VBA.
It takes a little bit more set up to begin with, but allows the production of elegant code at the end.

VBA Rounding

Posted on July 1, 2010 by Rob van Gelder

When comparing values from various systems, I’d sometimes notice $0.01 differences.
I put the differences down to rounding, but it seemed that no matter which approach I took, the differences could not be reconciled.
It’s one of those things that really bugged me, and I’d feel guilty if I spent too much time on the problem… after all, the differences added up to a lot less than the cost of my time.

The other day when I was comparing values in Excel I used the =ROUND() function and was shocked to see my old friend, the $0.01 difference.
The originating system was one designed by me using VBA, so I took the opportunity to look a bit deeper.
After some time, I isolated the problem to the VBA Round function.

In the image below, A1 to A20 are digits 0.0 to 1.9, B1 downward contains the formula =ROUND(A1, 0), and C1 down contains the formula =VBA_Round(A1, 0).
VBA Round

VBA_Round is a user defined function:

Function VBA_Round(number As Double, num_digits As Long) As Double
VBA_Round = Round(number, num_digits)
End Function

Excel will round 0.5 to 1, and VBA will round 0.5 to 0, yet they’ll both round 1.5 to 2.

It turned out that Excel and VBA use a different method of rounding, and it is by design.
Excel uses arithmetic rounding, and VBA uses Banker’s rounding. Bankers rounding means that you round a 5 to the nearest even number. There’s even a Microsoft Knowledge Base article about it.

For further reading, EWBI also has very good information on the topic.

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Author: Rob van Gelder

Copy Unique Values

Copy Chart as a Picture

Populating Class Properties

Sorting a Custom Collection Class

Good Row Bad Row

Class Property Fixed Values

Custom Collection Class

VBA Rounding