Cellules carrées

[VIARD]

Bonjour à toutes et à tous

Dans le cadre d'une présentation, je cherche à faire des cellules carrées.

Donc je vous soumets les petits codes que j'ai réalisé.
Ensuite, je vous expose ma doléance.

Pour le retour à la grille d'origine.
'============================================

Sub CelluleStandard()
Dim Lm%, i%, J%

Sheets("Feuil2").Activate
Application.ScreenUpdating = False
ActiveWindow.DisplayGridlines = True

Lm = 256
For i = 1 To Lm
Cells(i, 1).RowHeight = 12.75
Next
For J = 1 To Lm
Cells(1, J).ColumnWidth = 10.71
Next
For i = 1 To Lm
For J = 1 To Lm
Cells(i, J).Interior.Color = Blanc
Next
Next
ActiveWindow.DisplayGridlines = True
Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub

'===========================================

Lancement cellules carrées

'===========================================
Sub CelluleCarré()
Dim i%

Sheets("Feuil2").Select
Application.ScreenUpdating = False

For i = 1 To 10
DimensionCellule i, i
Next i
Application.ScreenUpdating = True
Cells.Select
Range("IV1").Activate
Selection.EntireColumn.Hidden = False
Range("A1").Select
Cells(1, 1).Activate
End Sub
'===========================================

Fonction cellules carrées

'============================================
Function DimensionCellule(ByVal X As Long, ByVal Y As Long) ', ByVal p As Long)
Dim h%, Point&, rng&, rng1&
Dim hauteur&, largeur&, rapport&

Cells(X, Y).Select
h = 10 '0.7 'dimension en millimètre, valeur limite = 0.7mm
Point = h / 0.35
'--------- hauteur en référence --------
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
'============================================

Ces modules sont à placer sur la feuille2

Avec ceci, je fais des cellules de n'importe quel taille, sauf quelles ne sont pas tout à fait carrées.
Par exemple pour une taille de 10mm de coté.
j'obtiens 47 pixels en largeur et 38 pixels en hauteur

Je n'arrive pas à faire mon asservissement sur les pixels.

Si quelqu'un peut me donner une piste.
En fait c'est surtout pour la beauté du résultat.

Bien amicalement
Jean-Paul

 

[MJ13]

Re : Cellules carrées

Bonjour Jean_Paul

Le mieux est de faire une rêgle de 3 entre les pixels et la taille afffichée.

Tu peux t'aider de traits qui ont une indication en taille en cm.

Ensuite à voir avec un double décimètre si à l'impression et à à l'écran ces mesures sont respectées.

Tiens nous au courant.

Edit: Bonjour Hasco . Après quelques tests, sur XL2007, j'ai mis à 123 pixels en hauteur et en largeur, j'obtiens un carré de 3,2 cm en largeur et de 3,5 cm en hauteur à l'impression. Voir Fichier joint.

 

[Guest]

Re : Cellules carrées

Bonjour Viard,

Salutations Michel

Excel arrondit toujours au Point le plus proche pour la hauteur des lignes.
Quand à la largeur des colonne l'unité de mesure largeur d'un caractère du style Normal. Il peut y avoir là une valeur fortement arrondie.

A+

 

[noviceAG]

Re : Cellules carrées

Bonjour à chacun, le Forum,

Ci-dessous, un ancien post :

Excel en centimètres - 29/06/2005 19:42 - PapyNovice - Messages: 169
Lien supprimé

Lien supprimé


Sub LignesEnCm()
Dim cm As Single
cm = Application.InputBox("hauteur de la ligne en cm.", Type:=1)
If cm Then
Selection.RowHeight = Application.CentimetersToPoints (cm)
End If
End Sub

Sub ColonnesEnCm()
Dim cm As Single, points As Single, savewidth As Single
Dim count As Single
Application.ScreenUpdating = False
cm = Application.InputBox ("Largeur de la colonne en cm.", Type:=1)
If cm = False Then Exit Sub
points = Application.CentimetersToPoints (cm)
savewidth = ActiveCell.ColumnWidth
ActiveCell.ColumnWidth = 255
If points > ActiveCell.Width Then
MsgBox "La largeur de" & cm & "est trop large" & Chr(10) & _
"la valeur maxi est de " & _
Format (ActiveCell.Width / 28.3464566929134, _
"0.00"), vbOkOnly + vbExclamation, "largeur non valable"
ActiveCell.ColumnWidth = savewidth
Exit Sub
End If
lowerwidth = 0
ipwidth = 255
ActiveCell.ColumnWidth = 127.5
curwidth = ActiveCell.ColumnWidth
count = 0
While (ActiveCell.Width <> points) And (count < 20)
If ActiveCell.Width < points Then
lowerwidth = curwidth
Selection.ColumnWidth = (curwidth + upwidth) / 2
Else
upwidth = curwidth
Selection.ColumnWidth = (curwidth + lowerwidth) / 2
End If
curwidth = ActiveCell.ColumnWidth
count = count + 1
Wend
End Sub


Par notre ami Mytå
Sub CelluleEnCentimetres()
Dim cm As Integer
cm = Application.InputBox("Hauteur de la cellule en cm.", Type:=1)
If cm Then
Selection.RowHeight = Application.CentimetersToPoints(cm)
End If
cm = Application.InputBox("Largeur de la cellule en cm.", Type:=1)
If cm Then
Selection.ColumnWidth = cm * 4.663
End If
End Sub

 

[VIARD]

Re : Cellules carrées

Bonjour à tous, MJ13, Hasco, NoviceAG

Je vous remercie pour vos suggestions
Je regarde à tête reposé
et vous tiendrai au courant.

Amicalement
Jean-Paul

 

[VIARD]

Re : Cellules carrées

Bonjour à tous

Je reviens avec mes cellules carrées.
Je vous expose mon programme, j'ai apporté quelques modification.
Dans mon asservissement, je suis partie du principe, quand partant d'une cellule rectangulaire
et en prenant la hauteur comme référence, j'asservis l'autre coté pour avoir un rapport 1.
Ici pour être plus efficace, j'impose dés le départ une valeur proche pour la largeur.
Pour bien voir la différence sur les petites valeurs de l'ordre du millimètre.
J'ai inséré un cercle de couleur.

Code à placé dans la feuille1

Option Explicit
'========================================================
Sub ColorierCellule(ByVal i As Long, ByVal j As Long)
Cells(i, j).Interior.Color = RGB(0, 0, 255)
End Sub

'=========================================================

' Fonction dimension cellule

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

Cells(x, y).Select
'h = 0.7 'dimension en millimètre, valeur limite = 0.7mm
Point = h / 0.35
With Selection
.RowHeight = Point
.ColumnWidth = 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 SaisieValeur(h, x)
Dim Message, Title, Default, MyValue

Message = "Entrez une valeur en mm"
Title = "Cellules carrées"
Default = x
h = Application.InputBox(Message, Title, Default, Type:=1)
End Sub
'=========================================================

' Lancement cellules carrées

'=========================================================
Sub CelluleCarré()
Dim i%, h%, x%

Sheets("Feuil1").Select
x = 10 'Valeur par défaut
SaisieValeur h, x
Call CelluleStandard
Application.ScreenUpdating = False
For i = 1 To 256
DimensionCellule i, i, h
Next i
Application.ScreenUpdating = True
Cells.Select
Range("IV1").Activate
Selection.EntireColumn.Hidden = False
ActiveWindow.DisplayGridlines = True
Call FormationCercle
Range("A1").Select
Cells(1, 1).Activate
End Sub
'==================================================
'==================================================

Sub SupprimerCouleurFeuille()
Call CelluleStandard
ActiveWindow.DisplayGridlines = True
ActiveSheet.UsedRange.Interior.Pattern = xlPatternNone
End Sub
'===================================================

'Mise au format d'origine des cellules

'===================================================
Sub CelluleStandard()
Dim Lm%, i%, j%

Sheets("Feuil1").Activate
Application.ScreenUpdating = False

Lm = 256
For i = 1 To Lm
Cells(i, 1).RowHeight = 12.75
Next
For j = 1 To Lm
Cells(1, j).ColumnWidth = 10.71
Next
For i = 1 To Lm
For j = 1 To Lm
Cells(i, j).Interior.Color = Blanc
Next
Next
ActiveSheet.UsedRange.Interior.Pattern = xlPatternNone
Application.ScreenUpdating = True

ActiveWindow.DisplayGridlines = True
Cells(1, 1).Select
End Sub

'=================================================================
'<<<<<<<<<<<<<<<<<<<<< Création Cercle Bleu >>>>>>>>>>>>>>>>>>>>>>>>>>>>
'=================================================================

Sub FormationCercle()
Dim x As Double, x1%
Dim y As Double, y1%
Dim i%, j1%, c As Long
Const Long2 As Integer = 70

For i = 0 To 360
x = Long2 * Sin(i * 3.1416 / 180)
y = Long2 * Cos(i * 3.1416 / 180)
x1 = Format(x, "##0.")
y1 = Format(y, "##0.")
TraceCercle x1, y1, j1
Next
End Sub

'===============================================
Sub TraceCercle(ByVal x1 As Long, ByVal y1 As Long, ByVal j1 As Long)
Dim OrigineX As Long, OrigineY As Long
Dim i As Long, j As Long

OrigineX = 128
OrigineY = 128
i = x1 + OrigineX
j = y1 + OrigineY
ColorierCellule i, j
End Sub

'===============================================

Salutation à tous
Jean-Paul