Set row height and column width in millimeters

 2016-09-08    Worksheets    2    257

Time to upgrade an old macro example that lets you set row heights and column widths using millimeters as a scale. This updated example handles multiple rows/columns/areas, and is also much faster changing the column widths for multiple columns than the original example. Both procedures now handles any worksheet size.

Sub SetRowHeight(objRange As Range, dblMillimeters As Double)
' updated 2016-09-08 by OPE
' changes the row height for all rows in objRange to dblMillimeters
' objRange can contain multiple areas
' dblMillimeters must be a value >= 0
' example: SetRowHeight Range("A1:A10"), 10 ' sets the row height in range A1:A10 to 10 millimeters
Dim dblPoints As Double, objArea As Range
    If objRange Is Nothing Then Exit Sub
    If objRange.Parent.ProtectContents Then Exit Sub ' protected worksheet
    If dblMillimeters < 0 Then Exit Sub
    
    Application.StatusBar = "Setting row height in [" & objRange.Parent.Parent.Name & "]" & objRange.Parent.Name & "!" & objRange.Address(False, False, xlA1) & " to " & dblMillimeters & " mm..."
    dblPoints = Application.CentimetersToPoints(dblMillimeters / 10) ' converts millimeters to points
    On Error Resume Next ' ignore errors, just in case dblMillimeters is a very large value
    For Each objArea In objRange.Areas
        objArea.EntireRow.RowHeight = dblPoints ' set the rowheight that will make the row height equal to dblMillimeters, rowheight is measured in points
    Next objArea
    Set objArea = Nothing
    On Error GoTo 0 ' resume normal error handling
    Application.StatusBar = False
End Sub

Sub SetColumnWidth(objRange As Range, dblMillimeters As Double)
' updated 2016-09-08 by OPE
' changes the column width for all columns in objRange to dblMillimeters
' objRange can contain multiple areas
' dblMillimeters must be a value >= 0
' example: SetColumnWidth Range("A1:Z1"), 25.4 ' sets the column width in range A1:Z1 to 25.4 millimeters
Dim dblColumnWidth As Double, objArea As Range
    If objRange Is Nothing Then Exit Sub
    If objRange.Parent.ProtectContents Then Exit Sub ' protected worksheet
    If dblMillimeters < 0 Then Exit Sub
    
    Application.StatusBar = "Setting column width in [" & objRange.Parent.Parent.Name & "]" & objRange.Parent.Name & "!" & objRange.Address(False, False, xlA1) & " to " & dblMillimeters & " mm..."
    dblColumnWidth = GetColumnWidth(objRange, dblMillimeters) ' returns a columnwidth that will make the column width in objRange equal to dblMillimeters
    If dblColumnWidth >= 0 Then
        On Error Resume Next ' ignore errors, just in case dblMillimeters is a very large value
        For Each objArea In objRange.Areas
            objArea.EntireColumn.ColumnWidth = dblColumnWidth ' set the columnwidth that will make the column width equal to dblMillimeters
        Next objArea
        Set objArea = Nothing
        On Error GoTo 0 ' resume normal error handling
    End If
    Application.StatusBar = False
End Sub

Private Function GetColumnWidth(objRange As Range, dblMillimeters As Double) As Double
' updated 2016-09-08 by OPE
' returns a columnwidth that will make the column width in objRange equal to dblMillimeters
' one unit of columnwidth is equal to the average width of one character in the font used in the Normal style (for proportional fonts the width of the character 0 (zero) is used)
' objRange can contain multiple areas
' dblMillimeters must be a value >= 0
' returns -1 if input is invalid
' example: dblColumnWidth = GetColumnWidth(Range("A1"), 25.4) ' returns a columnwidth that will make the column width equal to 25.4 millimeters
Dim dblPoints As Double, OK As Boolean, dblCurrentColumnWidth As Double, blnSaved As Boolean
    GetColumnWidth = -1 ' return value for invalid input
    If objRange Is Nothing Then Exit Function
    If objRange.Parent.ProtectContents Then Exit Function ' protected worksheet
    If dblMillimeters < 0 Then Exit Function
    
    OK = True
    blnSaved = objRange.Parent.Parent.Saved ' store the workbook saved status
    dblPoints = Application.CentimetersToPoints(dblMillimeters / 10) ' converts millimeters to points
    With objRange.Areas(1).Range("A1").EntireColumn
        dblCurrentColumnWidth = .ColumnWidth ' store the current column width
        On Error GoTo ErrorGettingColumnWidth
        Do While OK And .Width > dblPoints ' width is measured in points, but read only
            .ColumnWidth = .ColumnWidth - 0.1 ' one unit of columnwidth is equal to the average width of one character in the font used in the Normal style
        Loop
        Do While OK And .Width < dblPoints ' width is measured in points, but read only
            .ColumnWidth = .ColumnWidth + 0.1 ' one unit of columnwidth is equal to the average width of one character in the font used in the Normal style
        Loop
        If OK Then
            GetColumnWidth = .ColumnWidth ' returns the columnwidth that is equal to dblMillimeters
        End If
        .ColumnWidth = dblCurrentColumnWidth ' restore the current column width
        On Error GoTo 0 ' resume normal error handling
    End With
    If blnSaved Then
        objRange.Parent.Parent.Saved = True ' restore the workbook saved status
    End If
    Exit Function
    
ErrorGettingColumnWidth: ' error handler
    OK = False
    Resume Next
End Function

The original macros from 1999-12-20 can be found here:

Sub SetColumnWidthMM(ColNo As Long, mmWidth As Integer)
' updated 1999-12-20 by OPE
' changes the column width to mmWidth
Dim w As Single
    If ColNo < 1 Or ColNo > 255 Then Exit Sub
    Application.ScreenUpdating = False
    w = Application.CentimetersToPoints(mmWidth / 10)
    While Columns(ColNo + 1).Left - Columns(ColNo).Left - 0.1 > w
        Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth - 0.1
    Wend
    While Columns(ColNo + 1).Left - Columns(ColNo).Left + 0.1 < w
        Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth + 0.1
    Wend
End Sub

Sub SetRowHeightMM(RowNo As Long, mmHeight As Integer)
' updated 1999-12-20 by OPE
' changes the row height to mmHeight
    If RowNo < 1 Or RowNo > 65535 Then Exit Sub
    Rows(RowNo).RowHeight = Application.CentimetersToPoints(mmHeight / 10)
End Sub

Sub ExampleChangeWidthAndHeight()
    SetColumnWidthMM 3, 35 ' set the column with for column C to 35 mm
    SetRowHeightMM 3, 35 ' set the row height for row 3 to 35 mm
End Sub