Set row height and column width in millimeters
2016-09-08 Worksheets 2 671
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