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