On an overly abused workbook we've hit the limit and NumberFormats can no longer be added. If we do want to add more we need to consolidate current formats. My code requires a reference to Microsoft Scripting Runtime as it uses the Dictionary class. Is there anything I can do to further improve performance?

I started by looking for a NumberFormat already known to be in use on a worksheet.

Private Function GetFoundNumberFormatOnWS(ByVal numberFormatToFind As String, ByVal ws As Worksheet) As Range
    Application.FindFormat.NumberFormat = numberFormatToFind

    Dim searchArea As Range
    Set searchArea = ws.UsedRange
    Dim firstCell As Range
    Set firstCell = searchArea.Find(What:=vbNullString, After:=searchArea.Cells(searchArea.Rows.Count, searchArea.Columns.Count), SearchFormat:=True)
    Dim foundCell As Range
    Set foundCell = searchArea.Find(What:=vbNullString, After:=firstCell, SearchFormat:=True)

    If foundCell Is Nothing Or foundCell.Address = firstCell.Address Then
        Set GetFoundNumberFormatOnWS = firstCell
        Exit Function
    End If

    Set GetFoundNumberFormatOnWS = Union(firstCell, foundCell)

    Do While foundCell.Address <> firstCell.Address And Not foundCell Is Nothing
        'Range.Find() is used as Range.FindNext() doesn't search for a SearchFormat.
        Set foundCell = searchArea.Find(What:=vbNullString, After:=foundCell, SearchFormat:=True)
        If foundCell Is Nothing Then
            Exit Function
        End If
        Set GetFoundNumberFormatOnWS = Union(GetFoundNumberFormatOnWS, foundCell)
End Function

The next step was to search for all the NumberFormats on a given worksheet. If the NumberFormat is non-General I care about it and store it. delimitChar is a module level variable Private Const delimitChar As String = "|" since it is also used later as part of the table creation.

Public Function GetAllNumberFormatsFromWorksheet(ByVal ws As Worksheet) As Scripting.Dictionary
    Set GetAllNumberFormatsFromWorksheet = New Scripting.Dictionary
    Dim sheetName As String
    sheetName = ws.Name

    Dim cell As Range
    For Each cell In ws.UsedRange
        If cell.NumberFormat <> "General" Then
            Dim formatWSKey As String
            formatWSKey = cell.NumberFormat & delimitChar & sheetName
            If Not GetAllNumberFormatsFromWorksheet.Exists(formatWSKey) Then
                Dim foundCells As Range
                Set foundCells = GetFoundNumberFormatOnWS(cell.NumberFormat, ws)
                GetAllNumberFormatsFromWorksheet.Add formatWSKey, foundCells.Address
            End If
        End If
End Function

From there the next step was to get all the NumberFormats in a workbook.

Private Function GetAllNumberFormatsFromWorkbook(ByVal wb As Workbook) As Scripting.Dictionary
    Dim formatsInWorkbook As Scripting.Dictionary
    Set formatsInWorkbook = New Scripting.Dictionary
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        Dim formatsInWorksheet As Scripting.Dictionary
        Set formatsInWorksheet = GetAllNumberFormatsFromWorksheet(ws)
        Dim keyValue As Variant
        For Each keyValue In formatsInWorksheet.Keys
            formatsInWorkbook.Add keyValue, formatsInWorksheet.Item(keyValue)

    Set GetAllNumberFormatsFromWorkbook = formatsInWorkbook
End Function

When one of the function returns I can then use it to create a table from the consolidated information. The Keys and Items are converted to Nx1 "vertical" array for population.

Private Function CreateTable(ByVal numberFormatsDictionary As Scripting.Dictionary, ByVal addToWorkbook As Workbook) As ListObject
    Dim formatUsedOnWorksheet As Worksheet
    Set formatUsedOnWorksheet = addToWorkbook.Worksheets.Add
    formatUsedOnWorksheet.Name = "UsedNumberFormats"
    formatUsedOnWorksheet.Range("A1").Value2 = "NumberFormat"
    formatUsedOnWorksheet.Range("B1").Value2 = "Worksheet"
    formatUsedOnWorksheet.Range("C1").Value2 = "Cells"
    Const dataStartRow As Long = 2
    With formatUsedOnWorksheet.Cells(dataStartRow, 1).Resize(numberFormatsDictionary.Count, 1)
        .NumberFormat = "@"
        .Value2 = WorksheetFunction.Transpose(numberFormatsDictionary.Keys)
        'FieldInfo preserves `0.000` and `0.0` as distinct formats. Otherwise they
        'are treated as `0` and their distinct format is not preserved.
        .TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:=delimitChar, FieldInfo:=Array(Array(1, XlColumnDataType.xlTextFormat), Array(2, XlColumnDataType.xlGeneralFormat))
    End With

    'Originally Application.WorksheetFunction.Transpose() was used.
    'Under certain conditions it would error out
    Dim verticalArray() As Variant
    verticalArray = ConvertToVerticalArray(numberFormatsDictionary.Items)
    formatUsedOnWorksheet.Cells(dataStartRow, 3).Resize(numberFormatsDictionary.Count, 1).Value2 = verticalArray

    Set CreateTable = formatUsedOnWorksheet.ListObjects.Add(xlSrcRange, formatUsedOnWorksheet.Range("A1").CurrentRegion, XlListObjectHasHeaders:=xlYes)
End Function

Private Function ConvertToVerticalArray(ByRef horizontalArray As Variant) As Variant
    Dim lowerBound As Long
    lowerBound = LBound(horizontalArray)
    Dim upperBound As Long
    upperBound = UBound(horizontalArray)
    Dim elementCounter As Long
    Dim foo As Variant
    ReDim foo(lowerBound To upperBound, 0 To 0)
    For elementCounter = lowerBound To upperBound
        foo(elementCounter, 0) = horizontalArray(elementCounter)
    ConvertToVerticalArray = foo
End Function

The calling Sub takes the returned information and creates a table from it.

Public Sub AddWorksheetThatListsWhereNumberFormatsAreUsedInWorkbook()
    Dim usedInWB As Scripting.Dictionary
    Set usedInWB = GetAllNumberFormatsFromWorkbook(ThisWorkbook)
    With CreateTable(usedInWB, ThisWorkbook)
        .Sort.SortFields.Add .ListColumns(1).Range
        .Sort.SortFields.Add .ListColumns(2).Range
    End With
End Sub

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.