Sunday 19 August 2012

Join and Split functions for 2-Dimensional arrays

Here's something I fished out of the attic and posted into StackOverflow...

The code's trivial, in the sense that anyone can do a bit of string-concatenation and a Redim() statement and you've probably done some kind of 'Join' and 'Split' already. But there are a couple of points about efficient string-handling in the comments; or rather, overcoming the inefficiencies of a language which has no string-builder class.

Someday, you are going to find out that concatenating strings slows down *severely* for long strings, and you'll need to know how to work around that.

So, without further ado:

Join2d: A 2-Dimensional Join function in VBA with optimised string-handling

Coding notes:
  1. This 'Join' function does not suffer from the 255-char limitation that affects most (if not all) of the native Concatenate functions in Excel, and the Range.Value code sample above will pass in the data, in full, from cells containing longer strings.
  2. This is heavily optimised: we use string-concatenation as little as possible, as the native VBA string-concatenations are slow and get progressively slower as a longer string is concatenated.
If you want to look more deeply into optimising string-handling in VBA and the VB family of languages, advanced techniques are listed in parts I, II and II of this web article: http://www.aivosto.com/vbtips/stringopt3.html

The biggest performance gain available in native VBA is to avoid allocation and concatenation ( here's why: http://www.aivosto.com/vbtips/stringopt2.html#huge ) - so I use join, split, and replace instead of myString = MyString & MoreString

Bigger gains are available if you use the Kernel string functions directly: after that, you're Googling for LightningStrings and taking the big step into pointer arithmentic... Which I consider a step too far: if you need that kind of performance, you need another platform.



Public Function Join2d(ByRef InputArray As Variant, _ 
                       Optional RowDelimiter As String = vbCr, _ 
                       Optional FieldDelimiter = vbTab,_ 
                       Optional SkipBlankRows As Boolean = False _ 
                       ) As String

' Join up a 2-dimensional array into a string. Works like the standard
'  VBA.Strings.Join, for a 2-dimensional array.
' Note that the default delimiters are those inserted into the string
'  returned by ADODB.Recordset.GetString

On Error Resume Next

' Coding note: we're not doing any string-handling in VBA.Strings - 
' allocating, deallocating and (especially!) concatenating are SLOW.
' We're using the VBA Join & Split functions ONLY. The VBA Join,
' Split, & Replace functions are linked directly to fast (by VBA
' standards) functions in the native Windows code. Feel free to 
' optimise further by declaring and using the Kernel string functions
' if you want to.

' ** THIS CODE IS IN THE PUBLIC DOMAIN **
'   Nigel Heffernan   Excellerando.Blogspot.com

Dim i As Long
Dim j As Long

Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long

Dim arrTemp1() As String
Dim arrTemp2() As String

Dim strBlankRow As String

i_lBound = LBound(InputArray, 1)
i_uBound = UBound(InputArray, 1)

j_lBound = LBound(InputArray, 2)
j_uBound = UBound(InputArray, 2)

ReDim arrTemp1(i_lBound To i_uBound)
ReDim arrTemp2(j_lBound To j_uBound)

For i = i_lBound To i_uBound

    For j = j_lBound To j_uBound
        arrTemp2(j) = InputArray(i, j)
    Next j

    arrTemp1(i) = Join(arrTemp2, FieldDelimiter)

Next i

If SkipBlankRows Then

    If Len(FieldDelimiter) = 1 Then
        strBlankRow = String(j_uBound - j_lBound, FieldDelimiter)
    Else
        For j = j_lBound To j_uBound
            strBlankRow = strBlankRow & FieldDelimiter
        Next j
    End If

    Join2d = Replace(Join(arrTemp1, RowDelimiter), strBlankRow, RowDelimiter, "")
    i = Len(strBlankRow & RowDelimiter)

    If Left(Join2d, i) = strBlankRow & RowDelimiter Then
        Mid$(Join2d, 1, i) = ""
    End If

Else

    Join2d = Join(arrTemp1, RowDelimiter)    

End If

Erase arrTemp1

End Function
For completeness, here's the corresponding 2-D Split function:

Split2d: A 2-Dimensional Split function in VBA with optimised string-handling



Public Function Split2d(ByRef strInput As String, _ 
                        Optional RowDelimiter As String = vbCr, _ 
                        Optional FieldDelimiter = vbTab, _ 
                        Optional CoerceLowerBound As Long = 0 _ 
                        ) As Variant

' Split up a string into a 2-dimensional array. 

' Works like VBA.Strings.Split, for a 2-dimensional array.
' Check your lower bounds on return: never assume that any array in
' VBA is zero-based, even if you've set Option Base 0
' If in doubt, coerce the lower bounds to 0 or 1 by setting 
' CoerceLowerBound
' Note that the default delimiters are those inserted into the
'  string returned by ADODB.Recordset.GetString

On Error Resume Next

' Coding note: we're not doing any string-handling in VBA.Strings -
' allocating, deallocating and (especially!) concatenating are SLOW.
' We're using the VBA Join & Split functions ONLY. The VBA Join,
' Split, & Replace functions are linked directly to fast (by VBA
' standards) functions in the native Windows code. Feel free to 
' optimise further by declaring and using the Kernel string functions
' if you want to.

' ** THIS CODE IS IN THE PUBLIC DOMAIN **
'    Nigel Heffernan   Excellerando.Blogspot.com

Dim i   As Long
Dim j   As Long

Dim i_n As Long
Dim j_n As Long

Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long

Dim arrTemp1 As Variant
Dim arrTemp2 As Variant

arrTemp1 = Split(strInput, RowDelimiter)

i_lBound = LBound(arrTemp1)
i_uBound = UBound(arrTemp1)

If VBA.LenB(arrTemp1(i_uBound)) <= 0 Then  
    ' clip out empty last row: a common artifact in data 
     'loaded from files with a terminating row delimiter
    i_uBound = i_uBound - 1
End If

i = i_lBound
arrTemp2 = Split(arrTemp1(i), FieldDelimiter)

j_lBound = LBound(arrTemp2)
j_uBound = UBound(arrTemp2)

If VBA.LenB(arrTemp2(j_uBound)) <= 0 Then 
 ' ! potential error: first row with an empty last field...
    j_uBound = j_uBound - 1
End If

i_n = CoerceLowerBound - i_lBound
j_n = CoerceLowerBound - j_lBound

ReDim arrData(i_lBound + i_n To i_uBound + i_n, j_lBound + j_n To j_uBound + j_n)

' As we've got the first row already... populate it
' here, and start the main loop from lbound+1

For j = j_lBound To j_uBound
    arrData(i_lBound + i_n, j + j_n) = arrTemp2(j)
Next j

For i = i_lBound + 1 To i_uBound Step 1

    arrTemp2 = Split(arrTemp1(i), FieldDelimiter)

    For j = j_lBound To j_uBound Step 1

        arrData(i + i_n, j + j_n) = arrTemp2(j)

    Next j

    Erase arrTemp2

Next i

Erase arrTemp1

Application.StatusBar = False

Split2d = arrData

End Function
Share and enjoy... And watch out for unwanted line breaks in the code, inserted by your browser (or by Blogger's helpful formatting functions)

Wednesday 1 August 2012

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

Saturday 21 July 2012

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.

Friday 17 February 2012

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'