Je voudrais que mes cellules soient exactement carrées. Comment faire ?

sub FaireCarreEnmm()
     Dim WPChar As Double
     Dim DInch As Double
     Dim Temp As String
 
     Temp = InputBox("Hauteur,largeur en mm?")
     DInch = Val(Temp) / 25.4
     If DInch > 0 And DInch < 2.5 Then
     i = 0
       For Each col In ActiveWindow.RangeSelection.Columns
       i = i + 1
         If i = 1 Then
         col.EntireColumn.AutoFit
         WPChar = col.Width / col.ColumnWidth
         End If
         col.ColumnWidth = ((DInch * 72) / WPChar)
       Next col
       For Each lig In ActiveWindow.RangeSelection.Rows
         lig.RowHeight = (DInch * 72)
       Next lig
     End If
   end sub

Astuce illustrée par ce classeur
gd-annivdisciplus