XL 2019 VBA EXCEL

Function DimensionCellule(ByVal x As Long, ByVal y As Long)
'Auteur : JPV
Dim h%, Point&, rng&, rng1&
Dim hauteur&, largeur&, rapport&

Cells(x, y).Select
h = 8 'dimension en millimètre
Point = h / 0.35
With Selection
    .RowHeight = Point
End With
'------ asservissement pour avoir les cellules carrées ------
Do
    rng = ActiveCell.Width
    rng1 = ActiveCell.Height
    hauteur = ActiveCell.RowHeight
    largeur = ActiveCell.ColumnWidth
    rapport = rng / rng1
    With Selection
        .RowHeight = hauteur
        .ColumnWidth = largeur / rapport
    End With
Loop Until rapport = 1
End Function
'===============================
Sub CelluleCarré() 'Manip Test
Dim i%

Sheets("Feuil1").Select
Application.ScreenUpdating = False
For i = 1 To 9
    DimensionCellule i, i
Next i
Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
'================================

Sub NeufCellulesCarrées_et_plus_Follow_The_Line()
Set r = Range("A1:I9")
r.RowHeight = r.Width / r.Columns.Count: r.ColumnWidth = (((r.Width / r.Columns.Count) / 0.75 - 5) / 7)
r.ColumnWidth = (((r.Height / r.Rows.Count) / 0.75 - 5) / 7): r.RowHeight = r.Height / r.Rows.Count
ActiveWindow.Zoom = 40
End Sub

Sub dimrangecarré()
Range("A1:i9").ColumnWidth = Range("A1:i9").ColumnWidth / ( Cells(1).Width/ Cells(1).Height)
End Sub

Sub exo2()
Dim PL As Range
Dim LI As Byte
Dim COL As Byte

Set PL = Range("A1:I9")
PL.Columns.ColumnWidth = 6.43
PL.Rows.RowHeight = 37.5
PL.Interior.ColorIndex = xlNone
For LI = 1 To 9
    For COL = 1 To 9
        If LI = COL Or LI = 10 - COL Then
            Cells(LI, COL).Interior.ColorIndex = 3
        End If
    Next COL
Next LI
For LI = 1 To 9
    For COL = 2 To 8
        If COL >= LI + 1 And COL <= 9 - LI Then
            Cells(LI, COL).Interior.ColorIndex = 5
        End If
    Next COL
Next LI
End Sub

With Range("A1:I9")
  .ColumnWidth = 5  ' -->> choisir la taille que l'on veut
  .RowHeight = Range("A1").Width
End With