Return how many characters that will fit in the column width

As long as you are using the default/normal font this problem has a simple solution:
ActiveCell.ColumnWidth will return a numbers that represents the average character count that will fit inside the column width, assuming you are using the font defined in the Normal style.

If you are using a different font you can use the function below to return how many characters that on average will fit within a column using your own font and style:

Function GetColumnCharsCount(rngInputCell As Range, strFont As String, intSize As Integer, _
    blnBold As Boolean, blnItalic As Boolean) As Double
' returns the average count of characters that can be displayed within rngInputCell 
' for a given font, size and style
' rngInputCell is supposed to be a single cell only, 
' it can not be a cell in the last column in a worksheet
' example use:
' dblResult = GetColumnCharsCount(ActiveCell, "Arial", 14, True, False)
' dblResult = GetColumnCharsCount(Range("A1"), "Arial Narrow", 8, False, False)
Dim s As Style, asu As Boolean, c As Long, dblPixels(0 To 2) As Double
Dim strFont1 As String, intSize1 As Integer, blnBold1 As Boolean, blnItalic1 As Boolean
Dim dblColWidth As Double
    If rngInputCell Is Nothing Then Exit Function
    On Error Resume Next
    Set s = ActiveWorkbook.Styles("Normal")
    On Error GoTo 0
    If s Is Nothing Then Exit Function
    asu = Application.ScreenUpdating
    If asu Then
        Application.ScreenUpdating = False
    End If
    With s.Font
        ' store original settings for the Normal style
        strFont1 = .Name
        intSize1 = .Size
        blnBold1 = .Bold
        blnItalic1 = .Italic
        dblColWidth = rngInputCell.ColumnWidth
        ' get the average characters/pixel
        dblPixels(1) = dblColWidth / (rngInputCell.Offset(0, 1).Left - rngInputCell.Left)
        ' change to temporary settings for the Normal style
        .Name = strFont
        .Size = intSize
        .Bold = blnBold
        .Italic = blnItalic
        ' get the average characters/pixel
        dblPixels(2) = dblColWidth / (rngInputCell.Offset(0, 1).Left - rngInputCell.Left)
        ' restore original settings for the Normal style
        .Name = strFont1
        .Size = intSize1
        .Bold = blnBold1
        .Italic = blnItalic1
    End With
    If asu Then
        Application.ScreenUpdating = True
    End If
    ' calculate result
    GetColumnCharsCount = dblColWidth * dblPixels(2) / dblPixels(1)
End Function

Sub TestGetColumnCharsCount()
Dim dlbResult As Double
    dlbResult = GetColumnCharsCount(ActiveCell, "Verdana", 14, True, False)
    MsgBox "The active cell can on average display " & Format(dlbResult, "0.0") & _
        " characters in Verdana 14 point bold!", vbInformation
End Sub

Document last updated 2006-01-27 11:10:57 Printerfriendly version