A generic VBA Array To Range function

Here's a common task: writing an array to a range.

Here, we're writing an array to the sheet in a single 'hit' to the sheet. This is much faster than writing the data into the sheet one cell at a time in lops for the rows and columns.

However, there's some housekeeping to do, as you must specify the size of the target range correctly.

This 'housekeeping' looks like a lot of work and it's probably rather slow: but this is 'last mile' code to write to the sheet, and everything is faster than writing to the worksheet. Or at least, so much faster that it's effectively instantaneous, compared with a read or write to the worksheet, even in VBA, and you should do everything you possibly can in code before you hit the sheet.

A major component of this is error-trapping that I used to see turning up everywhere. I hate repetitive coding: I've coded it all here, and - hopefully - you'll never have to write it again.

As always, watch out for 'helpful' reformatting by your browser (or by Blogger) that inserts line breaks.

Option Explicit
                    
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet

' InputArray expects a 2-Dimensional structure of the form Variant(Rows, Columns)
' Vector arrays will be written as an array of 1 to n rows in a single column

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long
' strings and objects in the array, etc) then feel free to comment it out.

On Error Resume Next

'
' Author: Nigel Heffernan  Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True


If IsEmpty(InputArray) Then
    Exit Sub
End If

If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If


' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)


If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)


ElseIf iDimensions = 1 Then


    ReDim arrTemp(LBound(InputArray) To UBound(InputArray), 1 To 1)
    
    For iRow = LBound(InputArray) To UBound(InputArray)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next iRow
    
    ArrayToRange rngTarget, arrTemp
    Erase arrTemp
    
    

ElseIf iDimensions >= 2 Then
    
    
    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
    
    iStart = LBound(InputArray, 1)
    
    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If
    
    iStart = LBound(InputArray, 2)
    
    If iColCount > (rngTarget.Worksheet.Columns.Count - rngTarget.Column) Then
        iColCount = rngTarget.Worksheet.Columns.Count - rngTarget.Column - 1
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If
    
  
    With rngTarget.Worksheet
    
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
    
        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True
    
        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
        
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
            
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        ' Have we picked up values that can be read as a formula?
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                    
                Next iCol
                
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
            
        End If 'err<>0
    
        If Err <> 0 Then
        
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
    
                    
                    If IsError(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "#ERROR"
                    ElseIf IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You
                            ' have to go back and check, and write it out one cell at a time.
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
            
        End If 'err<>0
    
        If Err <> 0 Then
        
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True
    
        End If 'err<>0
    
    
        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time
    
    End With  '  rngTarget.Worksheet

End If  ' iDimensions

End Sub


Private Function ArrayTranspose(InputArray As Variant) As Variant

Dim arrOutput As Variant

Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long

iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)

ReDim arrOutput(jMin To jMax, iMin To iMax)

For i = iMin To iMax
    For j = jMin To jMax
        arrOutput(j, i) = InputArray(i, j)
    Next j
Next i

ArrayTranspose = arrOutput

End Function


Public Function ArrayDimensions(arr As Variant) As Integer
 ' Return values:
 
 ' -1 if arr is not an array
 '  0 for an array variant that has not been dimensioned
 '  1 to 255 for the array's dimensions.
 
 ' Special case: arr isn't a variant, it's a Range object
 ' Return the dimensions of the range's .Value() property
 
 ' VBA will pass the reference to a Range *object* (not the
 ' object's default property (the .Value variant) into your
 ' function, even though the parameter was declared as type
 ' variant. The  'least astonishment'  approach to handling
 ' that is to defer to the infallibility of Microsoft's API
 ' decisions and return the dimensions of the range's value
 
 ' We ignore the possibility of a range with multiple areas
 
 
Dim i As Integer
Dim j As Long

If TypeName(arr) = "Range" Then

    If arr Is Nothing Then
        ArrayDimensions = 0
    ElseIf arr.Areas(1).Cells.Count = 1 Then
        ArrayDimensions = 1
    Else
        ArrayDimensions = 2
    End If
    
ElseIf InStr(TypeName(arr), "(") < 1 Then

    ArrayDimensions = -1

ElseIf IsEmpty(arr) Then

    ArrayDimensions = 0
     
Else

    On Error Resume Next
    Err.Clear
    For i = 1 To 255
    
        j = 0
        j = UBound(arr, i)
    
        If Err.Number <> 0 Then
            ArrayDimensions = i - 1
            Exit For
        End If
        
    Next i
    
    If i > 255 Then ' not a VBA-compatible array
        ArrayDimensions = -1
    End If

End If

End Function

Please keep the acknowledgements in your source code: as you progress in your career as a developer, you will come to appreciate your own contributions being acknowledged.

Using the sadly broken Excel Worksheet 'CustomProperties' collection

I think the comment explains it all.

Public Function GetCustomProperty(ws As Worksheet, PropertyName As String) As Variant

' Return the value of a user-specified worksheet property created as:
'
p'   Ws.CustomProperties.Add Name:="Report Type", Value:"Balance Sheet"
'
' Return value is NULL if the named property does not exist
'

' Nigel Heffernan 07 April 2008

'   Return the value of an Excel Worksheet Custom Property
'   This is necessary because Microsoft have not implemented
'   CustomProperties as a VBA collection: names are not indexed
'   and the numeric position is NOT the ordinal: it's the
'   position of the named property in an alphabetic sort by name.
'
'   Maybe future releases will clear this up.
'

Dim i As Integer

GetCustomProperty = Null


    For i = 1 To ws.CustomProperties.Count
        If ws.CustomProperties(i).name = PropertyName Then
            GetCustomProperty = ws.CustomProperties(i).Value
            Exit Function
        End If
    Next i
    
End Function

Maybe this was fixed in 2010: it's still broken in Excel 2010. Some days, I think that Aspirin should be listed under 'Programming Tools'

The Flasher: Show A Cell, Cells, Or Merged Cells With A Warning Colour

This is a common theme: your sheet contains a cell for a file location, some macro runs with the value, and fails because the file address is invalid.

Fine, we've all written error-handlers for that, and we can write informative error messages telling the user what's gone wrong, and what to do next.

And we all *do* do this... Right?

As useful bit of user interface work is to flash up the range with the bad data, changing the background colour to red, and back again, two or three times. It's an easy bit of code to write, until you run into ranges containing merged cells - which are a nuisance, but an occasional necessity - because the range.interior.color property fails silently on merged cells.

We also have a second consideration: interior.color sometimes returns zero for cells with no interior colour. This is embarrassing when you've read the original colour as zero and 'restore' the range to that after flashing and ringing bells.

This is the code to flash a cell in red, three times (the default settings for 'WarningFlash'):

WarningFlash rngFileControl.Cells(iRow, iCol)

And this is what the code looks like to flash the cell (or merged cells) behind a command button, twice, in a tasteful yellow colour:

WarningFlash rngFileControl.Rows.Worksheet.OLEObjects("cmdSelectFiles").TopLeftCell, &HFFFF, 2

Note that we select the top-left cell of the range: my code for merged ranges only works if you specify the whole of the merge, or the first cell in the merge. And yes, I often put COM control buttons in merged cells: a well-formatted button with a 16*16 icon is twice the height of a standard Excel row, and I prefer to have the control in a merged single cell because 'move and size with cells' works badly if the control spans more than one cell.

Coding Note: best-practice would be to save your favourite colours as constants, or to use the built-in VBA colour constant for yellow: VBA.ColorConstants.vbYellow

So, without further ado, the source for the WarningFlash subroutine:

Public Sub WarningFlash(FlashRange As Excel.Range, _ 
                         Optional WarningColor As Long = &HFF, _ 
                         Optional FlashCount As Integer = 3)
 
Dim lngPriorColor As Long
Dim i As Integer
 
Dim rng As Excel.Range
 
    ' This unwieldly syntax works on ranges of merged cells, if you specify the top left cell
    Set rng = FlashRange.Areas(1).Worksheet.Range(FlashRange.Areas(1).Address)
 
    lngPriorColor = rng.Interior.Color
    If lngPriorColor = 0 Then Exit Sub
 
    For i = 1 To FlashCount
        rng.Interior.Color = WarningColor
        Sleep 500
        rng.Interior.Color = lngPriorColor
        Sleep 500
    Next i
 
End Sub

And now for the difficult bit: I'm using 'sleep', because Application.Wait only works in whole seconds. That API declaration needs to work in all Windows versions, and in all versions of VBA:

 
#If VBA7 And Win64 Then    ' 64 bit Excel under 64-bit windows
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#ElseIf VBA7 Then     ' 64 bit Excel in all environments
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else    ' 32 bit Excel
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Let me know how you get on: or, better still, post your own solutions.

Demising VBA: the caret and stick approach

I haven't been posting much in the last year, because the work I'm doing is under contract and I don't own the source code... So I can't publish it here. I can't complain: everyone's tightened up the IP and disclosure rules in their contracts and workng quietly beats hell out of not working.

So, in the absence of any actual content from me, here's a little gem from Tushar Mehta, on VBA in Office 2010:

To support this new data type, Microsoft also introduced the CLngLng function, the VarType constant vbLongLong, and the DefType statement DefLngLng. The type declaration character is ^. This can cause problems while typing VBA statements that use the exponentiation operator, which is also ^.

Feel free to read the details... And remember to insert a space before indicating an exponent in your calculations.

I wonder what else is out there, waiting to be discovered. I wonder, also, whether any other financial institution has made the transition to Office 2010, outside of a few 'early adopters' who amuse and entertain their IT staff with their ingenuity. We've only got about 50,000 regular users, worldwide - regular as in 'I use it every day in a critical part of my job', and probably twice that number of occasionals, so we're talking about a fair chunk of revenue for Microsoft here, and you'd think they'd make it easy for us to migrate.

Actually, you know Microsoft: you know damn' well they've made it difficult.

Everything we've done in terms of macros and reports, all the way up to add-ins and fully-developed applications, will need some testing - that's standard for all Office upgrades, even service patches - and we test the complex ones quite thoroughly. You'd think there might be tools, and scripts, and maybe even checklists and case studies. But no: Microsoft is unlike any other software vendor. And we start this job *knowing* that everything we've build that uses the application menubar is broken, by design, by Microsoft's insistence on imposing the new 'Ribbon Bar' with no concession whatsoever to supporting backward compatibility... I predict thet we'll be using Office 2003 well into 2012; and that there are major companies as big as us, or bigger, who'll be using it in 2014.

Ultimately, Microsoft will kill off VBA and this is just another nail in the coffin; they are, if you will, putting the caret before the hearse.

Adding a month to the end of the month: another Excel annoyance

Ever see a column of month-end payment days do this in a spreadsheet?

 31/08/2005

 30/11/2005

 28/02/2006

 28/05/2006

 28/08/2006

 28/11/2006

 28/02/2007

 28/05/2007

 28/08/2007

 28/11/2007

 28/02/2008

Sigh. All VBA developers eventually face the weary task of correcting the VBA.DateTime function library because of this loathsome miscoding by Microsoft:

' Special handling required for adding months at EOM:

' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)

' Business logic is ALWAYS that adding a month to EOM

' gives the end of the following month - 31 Mar 2006.

Here's my solution: I guess you've all got one of your own by now.



The usual health warning applies to ATTRIBUTE statements: they are not recognised by the VBA editor, you have to drag-and-drop the entire module out of the VB IDE, insert the statements manually in notepad, and drag the object back. In case you didn't know, the VB_ProcData attribute places AddDate in the 'Date & Time' category of the Spreadsheet Function Wizard, instead of letting it languish in obscurity under 'User-Defined'.

Public Function AddDate( _
        ByVal DateString As String, _
        Optional ByVal ReferenceDate As Date _
        Optional Subtract As Boolean = False _
        ) As Date

'ATTRIBUTE AddDate.VB_Description="Add a datestring of the form '1m', '10d' or '5y' to the reference date. \r\nBy default the reference date is the current date. \r\nInteger dates only: time expressed as fractional days is discarded. \r\nAll addition and subtraction uses Actual/Actual: no other date convention is implemented.

'ATTRIBUTE AddDate.VB_ProcData.VB_Invoke_Func = " \n2"




'Nigel Heffernan 2001 





'THIS CODE IS IN THE PUBLIC DOMAIN





'Add a datestring of the form '1m', '10d' or '5y' to the reference date.

'By default the reference date is the current date.

'Integer dates only: time expressed as fractional days is discarded.

'All addition and subtraction uses Actual/Actual: no other date convention is implemented.



Const VB_HELPFILE As String = "C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA6\1033\VbLR6.chm"

' I'm too lazy to do the proper registry lookup for this help file.



On Error GoTo ErrSub



Dim sNum As String

Dim iLen As Integer

Dim i As Long

Dim strLabel As String



If ReferenceDate = 0 Then

    ReferenceDate = Date

End If





DateString = Trim(UCase(DateString))

DateString = Left(DateString, 16)



If DateString = "SPOT" Then



    DateString = "2" 'Spot price - 'zero-day' plus settlement lag

    strLabel = "d"

    

ElseIf DateString = "OVERNIGHT" Then



    DateString = "1"

    strLabel = "d"

    

ElseIf DateString = "O/N" Then



    DateString = "1"

    strLabel = "d"



ElseIf DateString = "DAILY" Then



    DateString = "1"

    strLabel = "d"



ElseIf DateString = "WEEKLY" Then



    DateString = "7"

    strLabel = "d"

    

ElseIf DateString = "ANNUAL" Then



    DateString = "1"

    strLabel = "yyyy"  ' Year



ElseIf DateString = "YEARLY" Then



    DateString = "1"

    strLabel = "yyyy"  ' Year



ElseIf DateString = "MONTHLY" Then



    DateString = "1"

    strLabel = "m"



ElseIf DateString = "QUARTERLY" Then



    DateString = "3"

    strLabel = "m"



ElseIf DateString = "SEMI-ANNUAL" Then



    DateString = "6"

    strLabel = "m"



ElseIf DateString = "SEMIANNUAL" Then



    DateString = "6"

    strLabel = "m"



ElseIf InStr(DateString, "MONTH") Then



    iLen = InStr(DateString, "M")

    strLabel = "m"      ' Month"



ElseIf InStr(DateString, "YEAR") Then



    iLen = InStr(DateString, "Y")

    strLabel = "yyyy"  ' Year"



ElseIf InStr(DateString, "DAY") Then



    iLen = InStr(DateString, "D")

    strLabel = "d"      ' Day"



ElseIf InStr(DateString, "M") Then



    iLen = InStr(DateString, "M")

    strLabel = "m"      ' Month"



ElseIf InStr(DateString, "Y") Then



    iLen = InStr(DateString, "Y")

    strLabel = "yyyy"  ' Year"



ElseIf InStr(DateString, "D") Then



    iLen = InStr(DateString, "D")

    strLabel = "d"      ' Day"



ElseIf InStr(DateString, "Q") Then



    iLen = InStr(DateString, "Q")

    strLabel = "q"      ' Quarter"



ElseIf InStr(DateString, "W") Then



    iLen = InStr(DateString, "W")

    strLabel = "ww"     ' Week"



ElseIf IsNumeric(DateString) Then



    iLen = Len(DateString)

    strLabel = "d"      ' Day"

 

 

Else



    GoTo ErrSub

 

End If





sNum = Trim(Left(DateString, iLen - 1))

 



If Not IsNumeric(sNum) Then



    'Trim down until we reach a number

 

    Do Until IsNumeric(sNum) Or Len(sNum) < 1

 

        sNum = Left(sNum, Len(sNum) - 1)

        sNum = Trim(sNum)

 

        'Do not read "5-Year" as "Minus five years"

        If Right(sNum, 1) = "-" Then

            sNum = Left(sNum, Len(sNum) - 1)

            sNum = Trim(sNum)

        End If

  

    Loop

 

End If



If Len(sNum) < 1 Then

    GoTo ErrSub

End If



If Not IsNumeric(sNum) Then

    GoTo ErrSub

End If



i = CLng(sNum)



If Subtract Then

    i = -1 * i

End If



' Special handling required for adding months at EOM:

' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)

' Business logic is ALWAYS that adding a month to EOM

' gives the end of the following month - 31 Mar 2006.



If strLabel = "m" Then



    If Month(ReferenceDate) <> Month(ReferenceDate) + 1 Then 'EOM detected

        ReferenceDate = ReferenceDate + 1

        AddDate = DateAdd(strLabel, i, ReferenceDate)

        AddDate = AddDate - 1

    Else

        AddDate = DateAdd(strLabel, i, ReferenceDate)

    End If

    

Else



    AddDate = DateAdd(strLabel, i, ReferenceDate)

    

End If



ExitSub:

    Exit Function

    

ErrSub:



    If Len(Dir(VB_HELPFILE)) > 0 Then

        Err.Raise 13, "AddDate Function", _
         "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _
         & vbCrLf _
         & "Try typing '10d', '3m' or '5y', or the date " & vbCrLf _
         & "interval as a number of calendar days.", _
         VB_HELPFILE, 1000013

    Else

        Err.Raise 13, "AddDate Function", _
         "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _
         &  _
        vbCrLf _
         & "Try typing '10d', '3m' or '5y', or the date " &  _
        vbCrLf _
         & "interval as a number of calendar days."

    End If

        

End Function

Hashing algorithms: Adler32 implemented in VBA

I could've sworn I posted this here, years ago, but here's an implementation of Adler-32 in 32-bit VBA.

There's a horrible hack in it: Adler-32 returns a 32-bit integer, and the VBA Long is a signed integer with a range ± (2^31) -1, so I've implemented a 'wrap around' of the overflow at +2^31, restarting at -2^31 +1. And done something I really, really shouldn't have done with a floating-point variable. Eventually everyone, everywhere, will have 64-bit Office and this'll be kind of quaint and unnecessary... Right?

Of course, the real question is: why bother?

It boils down to the common question of checking for changes: if you don't want to use the 'on change' event, or you're dealing with data directly in VBA before it hits the sheet, large data sets need something better than an item-by-item brute force approach. At least, if you're doing it more than once: the cost of rolling each item into your hash is always more than the cost of the one-by-one comparison...

...And that's still true if you're importing a fast hashing algorithm from MySQL or one of the web API libraries (try MDA5, if you can get at an exposed function), unless you can find something that reads VBA variant arrays directly and relieve your VBA thread of the task of enumerating the list values into the imported function.

Meanwhile, here's a hash algorithm that's within reach of VBA: Adler32. The details are in Wikipedia’s article on Adler32: http://en.wikipedia.org/wiki/Adler-32 and an hour's testing will teach you some lessons about hashing:

1. 'Hash collisions' (differing data sets returning the same hash code) are more common than you expected, especially with data containing repeated patterns (like dates);>
2. Choice of hashing algorithm is important;
3. ...And that choice is more of an art than a science;
4. Admitting that you really shouldn't have bothered and resorting to brute force is often the better part of valour.

Adler-32 is actually more useful as a tool to teach those lessons, than as a workaday checksum. It's great for detecting changes in lists of more than 100 distinct items; it's tolerable, on a list of 24 randomly-generated 8-letter words (hash collisions at 1 in 1800 attempts) and it starts giving you single-digit percentage occurrences of the hash collision error in a list of 50 not-so-distinct option maturities, where the differences are mostly in the last 10 chars and *those* ten chars are recurring 3-month maturity dates.

By the time you're comparing pairs of 6-letter strings, more than 10% of your changes will be missed by the checksum in a non-random data set. And then you realise that might as well be using string comparison for that kind of trivial computation anyway.

So the answer is always: test it.

Meanwhile, here's the algorithm, horrible hacks and all:

Option Explicit


Public Function CheckSum(ByRef ColArray As Variant) As Long
Application.Volatile False

' Returns an Adler32 checksum of all the numeric and text values in a column

' Capture data from cells as myRange.Value2 and use a 32-bit checksum to see
' if any value in the range subsequently changes. You can run this on multi-
' column ranges, but it's MUCH faster to run this separately for each column
'
' Note that the VBA Long Integer data type is *not* a 32-bit integer, it's a
' signed integer with a range of  ± (2^31) -1. So our return value is signed
' and return values exceeding +2^31 -1 'wraparound' and restart at -2^31 +1.



' Coding Notes:

' This is intended for use in VBA, and not for use on the worksheet. Use the
' setting  'Option Private Module' to hide CheckSum from the function wizard


' Author: Nigel Heffernan, May 2006  http://excellerando.blogspot.com
' Acknowledgements and thanks to Paul Crowley, who recommended Adler-32

' Please note that this code is in the public domain. Mark it clearly, with
' the author's name, and segregate it from any proprietary code if you need
' to assert ownership & commercial confidentiality on your proprietary code

Const LONG_LIMIT As Long = (2 ^ 31) - 1
Const MOD_ADLER As Long = 65521

Dim a As Long
Dim b As Long

Dim i As Long
Dim j As Long
Dim k As Long

Dim arrByte() As Byte

Dim dblOverflow As Double


If TypeName(ColArray) = "Range" Then
    ColArray = ColArray.Value2
End If

If IsEmpty(ColArray) Then
    CheckSum = 0
    Exit Function
End If

If (VarType(ColArray) And vbArray) = 0 Then
    ' single-cell range, or a scalar data type
    ReDim arrData(0 To 0, 0 To 0)
    arrData(0, 0) = CStr(ColArray)
Else
    arrData = ColArray
End If


a = 1
b = 0


For j = LBound(arrData, 2) To UBound(arrData, 2)
    For i = LBound(arrData, 1) To UBound(arrData, 1)
        
        ' VBA Strings are byte arrays: arrByte(n) is faster than Mid$(s, n)
        
        arrByte = CStr(arrData(i, j))  ' Is this type conversion efficient?
        
        For k = LBound(arrByte) To UBound(arrByte)
            a = (a + arrByte(k)) Mod MOD_ADLER
            b = (b + a) Mod MOD_ADLER
        Next k
        
        ' Terminating each item with a 'vTab' char constructs a better hash
        ' than vbNullString which, being equal to zero, adds no information
        ' to the hash and therefore permits the clash ABCD+EFGH = ABC+DEFGH
        ' However, we wish to avoid inefficient string concatenation, so we
        ' roll the terminating character's bytecode directly into the hash:
        
        a = (a + 11) Mod MOD_ADLER                ' vbVerticalTab = Chr(11)
        b = (b + a) Mod MOD_ADLER
        
    Next i
    
    ' Roll the column into the hash with a terminating horizontal tab char:
    
    a = (a + 9) Mod MOD_ADLER                     ' Horizontal Tab = Chr(9)
    b = (b + a) Mod MOD_ADLER

    
Next j

' Using a float in an integer calculation? We can get away with it, because
' the float error for a VBA double is < ±0.5 with numbers smaller than 2^32

dblOverflow = (1# * b * MOD_ADLER) + a

If dblOverflow > LONG_LIMIT Then  ' wraparound 2^31 to 1-(2^31)
   
    Do Until dblOverflow < LONG_LIMIT
        dblOverflow = dblOverflow - LONG_LIMIT
    Loop
    CheckSum = 1 + dblOverflow - LONG_LIMIT
    
Else
    CheckSum = b * MOD_ADLER + a
End If

End Function

VLookup() with fuzzy-matching to get a 'closest match' result

Ever had to look up a name or an address in a list that doesn't quite match, so the standard Excel 'VLookup()' and 'Match()' functions don't help you?

Here's the solution:

The answer is 'Fuzzy Matching', a process of applying rules and picking out a 'best fit'. In the case of text - words, addresses, alphanumeric codes like ISIN identifiers for shares, bonds and other financial instruments - the best approach is the Levenshtein Edit Distance algorithm, a measure of how many characters were changed or moved to get from one text to another; but I've gone for a simplified approach that adds up how much of text A is made up of recognisable fragments of text B.

It works surprisingly well, but there are some limitations. There's a more detailed discussion of this in the preceding post: feel free to offer some suggestions and comments there: what you're reading here is the application of these abstract principles to spreadsheets. Click on the image: it'll show you how the function is used.

What's missing is a version of Match() (you can code that up for yourselves), and a dedicated 'FuzzyVLookupAddress()' function, tweaked to deal with the peculiar things that we do to postal addresses to make them extraordinarily difficult for computers (and spreadsheets!) to read. Instead, I've provided a crude 'NormaliseAddress' function, which standardises all those troublesome Aves, Avenues, Streets, Saints and St.'s. Apply it to the addresses in your list (and to the search term you're trying to look up) and let me know how you get on.

Enough witter: the code's below. It's been tested for cut-and-paste out of Blogger, but there's always a health warning: Blogger will munge the line breaks, and so will whatever you're using to view this post, especially if it's an RSS feed.

Option Explicit


Public Function FuzzyVLookup(Lookup_Value As String, _
                             Table_Array As Variant, _
                             Optional Col_Index_Num As Integer = 1, _
                             Optional Compare As VbCompareMethod = vbTextCompare _
                            ) As Variant

' Find the best match for a given string in column 1 of an array of data obtained from an Excel range
' This is functionally similar to VLookup, but it returns the best match, not the first exact match
' This function is not case-sensitive, unless you specify 'Compare' as 0 or vbBinaryCompare

' If your data quality is poor, you are advised to display the retrieved index value from column 1
' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and
' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!

' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and
' searched population to standardise abbreviations and word-order conventions used in British addresses.

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim dblBestMatch As Double

Dim iRowBest    As Integer
Dim dblMatch    As Double
Dim iRow        As Integer
Dim strTest     As String
Dim strInput    As String

Dim iStartCol   As Integer
Dim iEndCol     As Integer
Dim iOffset     As Integer

If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then
     'Table_Array is not an array
     FuzzyVLookup = "#VALUE"
    Exit Function
End If

If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then
    Table_Array = Table_Array.Value
End If

' If you get a subscript-out-of-bounds error here, you're using a vector instead
' of the 2-dimensional array that is the default 'Value' property of an Excel range.

iStartCol = LBound(Table_Array, 2)
iEndCol = UBound(Table_Array, 2)
iOffset = 1 - iStartCol


Col_Index_Num = Col_Index_Num - iOffset

If Col_Index_Num > iEndCol Or Col_Index_Num < iStartCol Then
     'Out-of-bounds
     FuzzyVLookup = "#VALUE"
    Exit Function
End If



    strInput = UCase(Lookup_Value)

    iRowBest = -1
    dblBestMatch = 0

    For iRow = LBound(Table_Array, 1) To UBound(Table_Array, 1)

        strTest = ""
        strTest = Table_Array(iRow, iStartCol)

        dblMatch = 0
        dblMatch = FuzzyMatchScore(strInput, strTest, Compare)

        If dblMatch = 1 Then ' Bail out on finding an exact match
            iRowBest = iRow
            Exit For
        End If

        If dblMatch > dblBestMatch Then
            dblBestMatch = dblMatch
            iRowBest = iRow
        End If

    Next iRow


    If iRowBest = -1 Then
        FuzzyVLookup = "#NO MATCH"
        Exit Function
    End If

    FuzzyVLookup = Table_Array(iRowBest, Col_Index_Num)

End Function
   
Public Function FuzzyHLookup(Lookup_Value As String, _
                             Table_Array As Variant, _
                             Optional Row_Index_Num As Integer = 1, _
                             Optional Compare As VbCompareMethod = vbTextCompare)

' Find the best match for a given string in Row 1 of an array of data obtained from an Excel range
' This is functionally similar to HLookup, but it returns the best match, not the first exact match
' This function is not case-sensitive, unless you specify 'Compare' as vbTextBinary.

' If your data quality is poor, you are advised to display the retrieved index value from row 1
' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and
' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!

' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and
' searched population to standardise abbreviations and word-order conventions used in British addresses.

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim dblBestMatch As Double

Dim iColBest    As Integer
Dim dblMatch    As Double
Dim iCol        As Integer
Dim strTest     As String
Dim strInput    As String

Dim iStartRow   As Integer
Dim iEndRow     As Integer
Dim iOffset     As Integer

If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then
     'Table_Array is not an array
     FuzzyHLookup = "#VALUE"
    Exit Function
End If

If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then
    Table_Array = Table_Array.Value
End If

' If you get a subscript-out-of-bounds error here, you're using a vector instead
' of the 2-dimensional array that is the default 'Value' property of an Excel range.

iStartRow = LBound(Table_Array, 1)
iEndRow = UBound(Table_Array, 1)
iOffset = 1 - iStartRow


Row_Index_Num = Row_Index_Num - iOffset

If Row_Index_Num > iEndRow Or Row_Index_Num < iStartRow Then
     'Out-of-bounds
     FuzzyHLookup = "#VALUE"
    Exit Function
End If


    strInput = UCase(Lookup_Value)

    iColBest = -1
    dblBestMatch = 0

    For iCol = LBound(Table_Array, 2) To UBound(Table_Array, 2)

        strTest = ""
        strTest = Table_Array(iStartRow, iCol)

        dblMatch = 0
        dblMatch = FuzzyMatchScore(strInput, strTest, Compare)

        If dblMatch = 1 Then ' Bail out on finding an exact match
            iColBest = iCol
            Exit For
        End If

        If dblMatch > dblBestMatch Then
            dblBestMatch = dblMatch
            iColBest = iCol
        End If

    Next iCol


    If iColBest = -1 Then
        FuzzyHLookup = "#NO MATCH"
        Exit Function
    End If

    FuzzyHLookup = Table_Array(Row_Index_Num, iColBest)

End Function


Public Function FuzzyMatchScore(ByVal str1 As String, _
                                ByVal str2 As String, _
                                Optional Compare As VbCompareMethod = vbTextCompare _
                                ) As Double

' Returns an estimate of how closely word 1 matches word 2: this is best displayed as a percentage
' This is calculated as the fraction of the longer string that is made up of recognisable fragments of the shorter string
' There is no support for wildcards and regular expressions. Case-sensitivity is determined by the 'compare' parameter

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim maxLen As Integer
Dim minLen As Integer

    If str1 = str2 Then
        FuzzyMatchScore = 1#
        Exit Function
    End If

    If Len(str1) > Len(str2) Then
        maxLen = Len(str1)
        minLen = Len(str2)
    Else
        maxLen = Len(str2)
        minLen = Len(str1)
    End If

    If Len(str1) = 0 Or Len(str2) = 0 Then
        FuzzyMatchScore = 0#
    Else

        FuzzyMatchScore = 0#
        FuzzyMatchScore = SumOfCommonStrings(str1, str2, Compare) / maxLen

    End If
   
End Function

Public Function SumOfCommonStrings( _
                            ByVal s1 As String, _
                            ByVal s2 As String, _
                            Optional Compare As VBA.VbCompareMethod = vbTextCompare, _
                            Optional iScore As Integer = 0 _
                                ) As Integer

Application.Volatile False

' N.Heffernan 06 June 2006 (somewhere over Newfoundland)
' THIS CODE IS IN THE PUBLIC DOMAIN


' Function to measure how much of String 1 is made up of substrings found in String 2

' This function uses a modified Longest Common String algorithm.
' Simple LCS algorithms are unduly sensitive to single-letter
' deletions/changes near the midpoint of the test words, eg:
' Wednesday is obviously closer to WedXesday on an edit-distance
' basis than it is to WednesXXX. So it would be better to score
' the 'Wed' as well as the 'esday' and add up the total matched

' Watch out for strings of differing lengths:
'
'    SumOfCommonStrings("Wednesday", "WednesXXXday")
'
' This scores the same as:
'
'     SumOfCommonStrings("Wednesday", "Wednesday")
'
' So make sure the calling function uses the length of the longest
' string when calculating the degree of similarity from this score.


' This is coded for clarity, not for performance.

Dim arr() As Integer    ' Scoring matrix
Dim n As Integer        ' length of s1
Dim m As Integer        ' length of s2
Dim i As Integer        ' start position in s1
Dim j As Integer        ' start position in s2
Dim subs1 As String     ' a substring of s1
Dim len1 As Integer     ' length of subs1

Dim sBefore1            ' documented in the code
Dim sBefore2
Dim sAfter1
Dim sAfter2

Dim s3 As String


SumOfCommonStrings = iScore

n = Len(s1)
m = Len(s2)

If s1 = s2 Then
    SumOfCommonStrings = n
    Exit Function
End If

If n = 0 Or m = 0 Then
    Exit Function
End If

's1 should always be the shorter of the two strings:
If n > m Then
    s3 = s2
    s2 = s1
    s1 = s3
    n = Len(s1)
    m = Len(s2)
End If

n = Len(s1)
m = Len(s2)

' Special case: s1 is n exact substring of s2
If InStr(1, s2, s1, Compare) Then
    SumOfCommonStrings = n
    Exit Function
End If

For len1 = n To 1 Step -1

    For i = 1 To n - len1 + 1

        subs1 = Mid(s1, i, len1)
        j = 0
        j = InStr(1, s2, subs1, Compare)
       
        If j > 0 Then
       
            ' We've found a matching substring...
            iScore = iScore + len1           

          ' Now clip out this substring from s1 and s2...
          ' And search the fragments before and after this excision:

       
            If i > 1 And j > 1 Then
                sBefore1 = left(s1, i - 1)
                sBefore2 = left(s2, j - 1)
                iScore = SumOfCommonStrings(sBefore1, _
                                            sBefore2, _
                                            Compare, _
                                            iScore)
            End If
   
   
            If i + len1 < n And j + len1 < m Then
                sAfter1 = right(s1, n + 1 - i - len1)
                sAfter2 = right(s2, m + 1 - j - len1)
                iScore = SumOfCommonStrings(sAfter1, _
                                            sAfter2, _
                                            Compare, _
                                            iScore)
            End If
   
   
            SumOfCommonStrings = iScore
            Exit Function

        End If

    Next


Next


End Function


Private Function Minimum(ByVal a As Integer, _
                         ByVal b As Integer, _
                         ByVal c As Integer) As Integer
Dim min As Integer

  min = a

  If b < min Then
        min = b
  End If

  If c < min Then
        min = c
  End If

  Minimum = min

End Function



Public Function NormaliseAddress(ByVal strAddress As String) As String
Application.Volatile False
' This function is intended to remove or standardise common phrases
' and abbreviations used in British postal addresses, allowing the use
' of string-comparison algorithms in lists of names and addresses.

' Developers in other countries should review the word list used here,
' as conventions probably differ in your local language or dialect.

strAddress = " " & UCase(strAddress) & " "

strAddress = Substitute(strAddress, ",", " ")
strAddress = Substitute(strAddress, ".", " ")
strAddress = Substitute(strAddress, "-", " ")
strAddress = Substitute(strAddress, vbCrLf, " ")
strAddress = Substitute(strAddress, " BLVD ", " BOULEVARD ")
strAddress = Substitute(strAddress, " BVD ", " BOULEVARD ")
strAddress = Substitute(strAddress, " AV ", " AVENUE ")
strAddress = Substitute(strAddress, " AVE ", " AVENUE ")
strAddress = Substitute(strAddress, " RD ", " ROAD ")
strAddress = Substitute(strAddress, " WY ", " WAY ")
strAddress = Substitute(strAddress, " EST ", " ESTATE ")
strAddress = Substitute(strAddress, " PL ", " PLACE ")
strAddress = Substitute(strAddress, " PK ", " PARK ")
strAddress = Substitute(strAddress, " HSE ", " HOUSE ")
strAddress = Substitute(strAddress, " H0 ", " HOUSE ")
strAddress = Substitute(strAddress, " GDNS ", " GARDENS ")

strAddress = Substitute(strAddress, "&", "AND")
strAddress = Substitute(strAddress, " LIMITED ", " LTD ")
strAddress = Substitute(strAddress, " COMPANY ", " CO ")
strAddress = Substitute(strAddress, " CORPORATION ", " CORP ")
strAddress = Substitute(strAddress, " T/A ", " TA ")
strAddress = Substitute(strAddress, " TRADING AS ", " TA ")

' Common personal titles: these are often applied inconsistently or
' omitted, and must therefore be removed. Specific applications may
' require additional titles and their abbreviations - military rank,
' academic titles and degrees, courtesy titles of the aristocracy,
' knighthoods and honours (particularly for lists of civil servants)

strAddress = Substitute(strAddress, " ESQ ", " ")
strAddress = Substitute(strAddress, " MR ", " ")
strAddress = Substitute(strAddress, " MRS ", " ")
strAddress = Substitute(strAddress, " MISS ", " ")
strAddress = Substitute(strAddress, " MS ", " ")
strAddress = Substitute(strAddress, " MESSRS ", " ")
strAddress = Substitute(strAddress, " SIR ", " ")
strAddress = Substitute(strAddress, " OF ", " ")
strAddress = Substitute(strAddress, " DR ", " ")
strAddress = Substitute(strAddress, " OR ", " ")
strAddress = Substitute(strAddress, " IN ", " ")
strAddress = Substitute(strAddress, " THE ", " ")
strAddress = Substitute(strAddress, " REVEREND ", " REV ")
strAddress = Substitute(strAddress, " REVERENT ", " REV ")
strAddress = Substitute(strAddress, " HONOURABLE ", " HON ")
strAddress = Substitute(strAddress, " BROS ", " BROTHERS ")
strAddress = Substitute(strAddress, " ASSOC ", " ASSOCIATION ")
strAddress = Substitute(strAddress, " ASSN ", " ASSOCIATION ")

' Standardising 'St.', 'St', and 'Street'. Note that there are over 40 English
' towns and place names that contain or consist entirely of the word 'Street'.
' In addition, 'St' is a common abbreviation for 'Saint' in addresses.

' I have never seen a list of addresses where 'Street' and 'St' were used in a
' consistent way, and the only workable solution is to delete them all:

strAddress = Substitute(strAddress, " STREET ", " ")
strAddress = Substitute(strAddress, " ST ", " ")
strAddress = Substitute(strAddress, " STR ", " ")

Do While InStr(strAddress, "  ") > 0
    strAddress = Substitute(strAddress, "  ", " ")
Loop

strAddress = Trim(strAddress)

NormaliseAddress = strAddress

End Function


Public Function StripChars(myString As String, ParamArray Exceptions()) As String

' Strip out all non-alphanumeric characters from a string in a single pass
' Exceptions parameters allow you to retain specific characters (eg: spaces)

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim i As Integer
Dim iLen As Integer
Dim chrA As String * 1
Dim intA As Integer
Dim j As Integer
Dim iStart As Integer
Dim iEnd As Integer

If Not IsEmpty(Exceptions()) Then
    iStart = LBound(Exceptions)
    iEnd = UBound(Exceptions)
End If

iLen = Len(myString)

For i = 1 To iLen
    chrA = Mid(myString, i, 1)
    intA = Asc(chrA)
    Select Case intA
    Case 48 To 57, 65 To 90, 97 To 122
        StripChars = StripChars & chrA
    Case Else
        If Not IsEmpty(Exceptions()) Then
            For j = iStart To iEnd
                If chrA = Exceptions(j) Then
                    StripChars = StripChars & chrA
                    Exit For ' j
                End If
            Next j
        End If
    End Select
Next i



End Function


Private Function Substitute(ByVal Text As String, _
                            ByVal Old_Text As String, _
                            ByVal New_Text As String, _
                            Optional Instance As Long = 0, _
                            Optional Compare As VbCompareMethod = vbTextCompare _
                            ) As String


' Replace all instances (or the nth instance ) of 'Old' text with 'New'
' Unlike VB.Mid$ this method is not sensitive to length and can replace ALL instances
' This is not exposed as a Public function because there is an Excel Worksheet function
' called Substitute(). However, Workheet Functions have length constraints.

' THIS CODE IS IN THE PUBLIC DOMAIN

Dim iStart As Long
Dim iEnd As Long
Dim iLen As Long
Dim iInstance As Long
Dim strOut As String

iLen = Len(Old_Text)

If iLen = 0 Then
    Substitute = Text
    Exit Function
End If

iEnd = 0
iStart = 1

iEnd = InStr(iStart, Text, Old_Text, Compare)

If iEnd = 0 Then
    Substitute = Text
    Exit Function
End If


strOut = ""

Do Until iEnd = 0

    strOut = strOut & Mid$(Text, iStart, iEnd - iStart)
    iInstance = iInstance + 1

    If Instance = 0 Or Instance = iInstance Then
        strOut = strOut & New_Text
    Else
        strOut = strOut & Mid$(Text, iEnd, Len(Old_Text))
    End If

    iStart = iEnd + iLen
    iEnd = InStr(iStart, Text, Old_Text, Compare)

Loop

iLen = Len(Text)
strOut = strOut & Mid$(Text, iStart, iLen - iEnd)

Substitute = strOut

End Function

This is something I coded up on an obscure personal blog a couple of years ago: I get one or two enquiries about it every year (mostly appreciative) so I've tidied it up, tested it more thoroughly, and released it into the wild on Excellerando.