VBA Excel set columns width/rows height in millimeters

I wanted to get an Excel table with fixed dimensions (in millimeters). But Excel works with different units, not to say that column width and row heights are handled completely different.

Searching the web, did get to a viable code, but it was extremelly slow (when a bunch of resizes has to be performed). So I tunned the code a bit, with a first approximation to the final width objective, so less resize operations had to be carried out.

Here is the code, hope it helps:

Option Explicit

Sub ChangeWidthAndHeight()
    SetColumnWidthMM 1, 10
    SetRowHeightMM 1, 10
End Sub

Private Sub SetRowHeightMM(ByVal RowNo As Long, _
                           ByVal mmHeight As Integer)
' changes the Row Height to mm Height
    With ActiveSheet
        If RowNo < 1 Or RowNo > .Rows.Count Then Exit Sub
    End With
    
    With Application
        .ScreenUpdating = False
        ActiveSheet.Rows(RowNo).RowHeight = .CentimetersToPoints(mmHeight / 10)
        .ScreenUpdating = True
    End With
End Sub

Private Sub SetColumnWidthMM(ByVal ColNo As Long, _
                             ByVal mmWidth As Integer)
' changes the column width to mm Width
' Column widths are not really measured in any "unit" as such.
' Instead, the number refers to the number of characters which can be displayed in the column.
' For variable width fonts such as Arial, the "0" character is used.
' In VBA, the ColumnWidth property uses this measure of width, and the Width property uses Points.
' 1 inch = 72 points
' 1 pointH = 1/72 inches.
' 1 pointH = 0.0353 centimeters (or .353 millimetre)
' 1 pointH = ... x pixels
    
    Dim w As Single
    Dim wSize As Single
    
    With ActiveSheet
        If ColNo < 1 Or ColNo > .Columns.Count Then Exit Sub
    End With
    
    Application.ScreenUpdating = False
    
    w = Application.CentimetersToPoints(mmWidth / 10)
    With ActiveSheet
        wSize = (.Columns(ColNo + 1).Left - .Columns(ColNo).Left)
        
        ' First approximation:
        With .Columns(ColNo)
            .ColumnWidth = .ColumnWidth * (w / wSize)
        End With
        
        While .Columns(ColNo + 1).Left - .Columns(ColNo).Left - 0.1 > w
            '.Columns(ColNo).ColumnWidth = .Columns(ColNo).ColumnWidth - wMove
            With .Columns(ColNo)
                'Debug.Print .ColumnWidth
                .ColumnWidth = .ColumnWidth - 0.1
            End With
        Wend
        While .Columns(ColNo + 1).Left - .Columns(ColNo).Left + 0.1 < w
            With .Columns(ColNo)
                'Debug.Print .ColumnWidth
                .ColumnWidth = .ColumnWidth + 0.1
            End With
        Wend
    End With
    
    Application.ScreenUpdating = True
End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *