Eviter le chevauchement de rectangle - Excel

Discussion générale entre passionnés et amateurs de mathématiques sur des sujets mathématiques variés
Lixil
Messages: 1
Enregistré le: 29 Aoû 2021, 23:38

Eviter le chevauchement de rectangle - Excel

par Lixil » 30 Aoû 2021, 00:55

Bonjour à tous,

Je travaille beaucoup sur Excel et je rencontre aujourd'hui une difficulté.

J'ai créé un graphique à barre dynamique dans mon fichier Excel.
Pour chaque barres du graphique, j'ai une étiquette de donnée (ED) qui indique le nom de la barre et sa valeur.

Le problème est que tout se chevauche tout le temps et donc c'est illisible.

je cherche une solution mathématique qui me permettrait d'éviter ces chevauchements en plaçant les étiquettes de données en fonction des précédentes (via Visual Basic).

D'habitude je cherche sur les forums dédiés à Excel mais pour ce cas présent, je pense qu'un forum mathématique est plus adapté à mon problème.

Les informations dont je dispose :
- Je connais les dimensions du graphique (Hauteur = 1000, Longueur = 2000) => Nommé le "cadre" par la suite.
- Je connais les dimensions des étiquettes de données (ED) ainsi que leur position dans le cadre.
ED de la barre 1 : ED1
Hauteur = 10 ;
Longueur = 20 ;
Top = 50 ; (La barre supérieur du rectangle ED1 se situe à 50 unités de la barre supérieur du cadre)
Left = 20. (La barre gauche du rectangle ED1 se situe à 20 unités de la barre gauche du cadre)


ED de la barre 2 : ED2
Hauteur = 45 ;
Longueur = 25 ;
Top = 20 ; (La barre supérieur du rectangle ED2 se situe à 20 unités de la barre supérieur du cadre)
Left = 35. (La barre gauche du rectangle ED2 se situe à 35 unités de la barre gauche du cadre)


Etc. Jusque EDn

Dans cette exemple on peut voir que la surface ED2 chevauche la surface de ED1.

J'ai une petite idée pour trouver une solution à mon problème mais elle ne me convient pas trop.
Elle consiste en plusieurs étapes :
1ere étape : Créer sur une feuille excel les dimensions du cadre et mettre toutes les cellules à l'intérieur en couleur (bleu par exemple).
2ème étape : Changer la couleur des cellules représentant ED1 (mettre en jaune)
3ème étape : Avant de positionner ED2, je regarde si les cellules correspondant à ses coordonnées sont toutes en bleu.
Si tout est bleu alors pas de problème je peux positionner ED2.
Si présence de jaune alors je modifie la variable "Top" jusqu'à ne plus avoir de jaune sur l'emplacement de ED2.

4eme étape : répéter l’étape 3 jusque EDn

Je ne sais pas si c'est possible de faire la même chose mais via une formule ou matrice... je sais pas trop. Je cherche des pistes de réflexion.

Merci par avance pour vos réponses

Lixil



lyceen95
Membre Irrationnel
Messages: 1391
Enregistré le: 15 Juin 2019, 01:42

Re: Eviter le chevauchement de rectangle - Excel

par lyceen95 » 30 Aoû 2021, 20:06

Ca m'a bien amusé comme challenge ... alors voici une macro.
La macro alea_rectangle génère 40 rectangles , sur une zone limitée, donc plein de chevauchements.
La macro deplace_rectangles() essaie de supprimer les superpositions.

Mathématiquement, ça ne repose sur rien du tout. Je traite les rectangles 1 par 1 , dans l'ordre où ils arrivent.
Donc par exemple, à partir d'une même situation de départ, si les rectangles A et B étaient renumérotés en B et A, on arriverait à une position finale éventuellement très différente.
J'ai mis plein de commentaires, pour la compréhension.
J'arrête le process au bout de 30 itérations... sur les tests que j'ai faits, sur les données que j'ai, il reste des chevauchements mineurs.

Il y a une impasse assumée dans le code. Si on a 2 rectangles qui se superposent, et tels que largeur1+largeur2 serait plus grand que largeur_max, alors l'un des 2 rectangles pourrait se retrouver éventuellement 'hors champ'.
Idem pour la hauteur
C'est assez facile à corriger.

Code: Tout sélectionner

 
Dim delta_a As Integer, delta_b As Integer

Const CST_Vertical As Integer = 1
Const CST_Horizontal As Integer = 2

Const hauteur_max As Integer = 600
Const largeur_max As Integer = 1000



Function f_superpose(shX As Shape, shy As Shape)
   
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pb As Integer

' On commence par regarder l'axe vertical

pb = 0

x1 = shX.Top
x2 = shX.Top + shX.Height
y1 = shy.Top
y2 = shy.Top + shy.Height

If x1 > y1 And x1 < y2 Then pb = 1
If x2 > y1 And x2 < y2 Then pb = 1
If y1 > x1 And y1 < x2 Then pb = 1
If y2 > x1 And y2 < x2 Then pb = 1

If pb = 0 Then
    f_superpose = 0
    Exit Function
End If
delta_a = fmin(x2, y2) - fmax(x1, y1)    ' La hauteur du chevauchement sera de delta_a, si chevauchement il y a.

' Sur l'axe vertical, il y a risque de chevauchement
' Regardons l'axe horizontal

pb = 0

x1 = shX.Left
x2 = shX.Left + shX.Width
y1 = shy.Left
y2 = shy.Left + shy.Width

If x1 > y1 And x1 < y2 Then pb = 1
If x2 > y1 And x2 < y2 Then pb = 1
If y1 > x1 And y1 < x2 Then pb = 1
If y2 > x1 And y2 < x2 Then pb = 1
   
If pb = 0 Then
    f_superpose = 0
    Exit Function
End If
 
delta_b = fmin(x2, y2) - fmax(x1, y1)    ' La largeur du chevauchement est de delta_b.
f_superpose = 1
End Function
' ------------------------------
Function fmax(a, b)
fmax = b
If a > b Then fmax = a
End Function
' --------------------------------
Function fmin(a, b)
fmin = b
If a < b Then fmin = a
End Function
' -------------------------------
Sub alea_rectangle()
   
Dim i As Integer
Dim a1 As Double, a2 As Double, b1 As Double, b2 As Double
Dim coul_1 As Integer, coul_2 As Integer, coul_3 As Integer

i = 0

coul_1 = 80
coul_2 = 10
coul_3 = 128

For Each sh In ActiveSheet.Shapes
    sh.Delete
Next sh

While i < 40  ' Je génére aléatoirement 40 rectangles
    a1 = Int(Rnd() * (largeur_max - 60))
    a2 = 60 + Int(Rnd() * 120)
    b1 = Int(Rnd() * (hauteur_max - 25))
    b2 = 25 + Int(Rnd() * 60)
    If a1 + a2 <= largeur_max And b1 + b2 <= hauteur_max Then
        i = i + 1
       
        With ActiveSheet.Shapes.AddShape(msoShapeRectangle, a1, b1, a2, b2)
       
            .Fill.ForeColor.RGB = RGB(coul_1, coul_2, coul_3)
        End With
         
        ' Je colorie mes rectangles de couleurs toutes différentes, pour reconnaitre avant/après.
        coul_1 = coul_1 + 40
        coul_2 = coul_2 + 55
        coul_3 = coul_3 + 88
        If coul_1 > 255 Then coul_1 = coul_1 - 256
        If coul_2 > 255 Then coul_2 = coul_2 - 256
        If coul_3 > 255 Then coul_3 = coul_3 - 256
       
    End If
Wend

End Sub
Sub deplace_rectangles()

'Dim nrectangle As Integer
'nrectangle = ActiveSheet.Shapes.Count

Dim sh01 As Shape, sh02 As Shape

Dim normal_inverse As Integer

iter = 1
probleme = 1
While probleme > 0
    probleme = 0
    ' MsgBox (iter)
    ' Quand 2 rectangles se superposent, on cherche la direction (horizontal ou Vertical) qui va nécessiter le déplacement mini
    ' Mais une itération sur 3, on prend l'autre direction... parce que visiblement, la direction idéale n'est pas satisfaisante (télescopage)
    normal_inverse = 1
    If iter Mod 3 = 0 Then normal_inverse = 2
 
    For Each sh01 In ActiveSheet.Shapes
        For Each sh02 In ActiveSheet.Shapes
            If sh01.Name <> sh02.Name Then
                ok_superpose = f_superpose(sh01, sh02)
                If ok_superpose = 1 Then
                    probleme = 1
                    ' delta_a donne la hauteur du rectangle intersection , et delta_b sa largeur.
                    ' je cherche laquelle de ces 2 valeurs est la plus petite, je vais déplacer les rectangles horizontalement ou verticalement, pour avoir un déplacement minimal
                    If delta_a < delta_b Then
                        mvt = CST_Vertical
                    Else
                        mvt = CST_Horizontal
                    End If
                    If normal_inverse = 1 Then
                        ' A force d'essayer selon une direction, et d'échouer, on tente selon l'autre direction.
                        ' et tant pis si ça oblige à des déplacements plus grands
                        mvt = 3 - mvt
                    End If
           
                    If mvt = CST_Vertical Then
                        ' Je déplace verticalement
                        ' Est-ce que je monte sh01 ou sh02 ?
                        If sh01.Top + sh01.Height / 2 < sh02.Top + sh02.Height / 2 Then
                            ' je monte sh01 et je descend sh02
                           
                            sh01.Top = sh01.Top - delta_a / 2
                            sh02.Top = sh02.Top + delta_a / 2
                            If sh01.Top < 0 Then
                                sh02.Top = sh02.Top - sh01.Top
                                sh01.Top = 0
                            End If
                            If sh02.Top + sh02.Height > hauteur_max Then
                                sh01.Top = sh01.Top - (sh02.Top + sh02.Height - hauteur_max)
                                sh02.Top = hauteur_max - sh02.Height
                            End If
                        Else               
                            sh02.Top = sh02.Top - delta_a / 2
                            sh01.Top = sh01.Top + delta_a / 2
                            If sh02.Top < 0 Then
                                sh01.Top = sh01.Top - sh02.Top
                                sh02.Top = 0
                            End If
                            If sh01.Top + sh01.Height > hauteur_max Then
                                sh02.Top = sh02.Top - (sh01.Top + sh01.Height - hauteur_max)
                                sh01.Top = hauteur_max - sh01.Height
                            End If
                       
                        End If
                    Else
                        ' Je déplace horizontalement
                        ' Est-ce que je décale vers la droite  sh01 ou sh02 ?
                        If sh01.Left + sh01.Width / 2 < sh02.Left + sh02.Width / 2 Then
                            ' je monte sh01 et je descend sh02
                                                     
                            sh01.Left = sh01.Left - delta_b / 2
                            sh02.Left = sh02.Left + delta_b / 2
                            If sh01.Left < 0 Then
                                sh02.Left = sh02.Left - sh01.Left
                                sh01.Left = 0
                            End If
                            If sh02.Left + sh02.Width > largeur_max Then
                                sh01.Left = sh01.Left - (sh02.Left + sh02.Width - largeur_max)
                                sh02.Left = largeur_max - sh02.Width
                            End If
                           
                        Else
                            sh02.Left = sh02.Left - delta_b / 2
                            sh01.Left = sh01.Left + delta_b / 2
                            If sh02.Left < 0 Then
                                sh01.Left = sh01.Left - sh02.Left
                                sh02.Left = 0
                            End If
                            If sh01.Left + sh01.Width > largeur_max Then
                                sh02.Left = sh02.Left - (sh01.Left + sh01.Width - largeur_max)
                                sh01.Left = largeur_max - sh01.Width
                            End If
                       
                        End If
                    End If
                End If
            End If
        Next sh02
    Next sh01
    iter = iter + 1
    If iter > 30 Then
        probleme = 0 ' Si au bout de 30 itérations, on n'a toujours pas réussi, abandon.
    End If
Wend

End Sub

 

Retourner vers ⚜ Salon Mathématique

Qui est en ligne

Utilisateurs parcourant ce forum : Aucun utilisateur enregistré et 6 invités

Tu pars déja ?



Fais toi aider gratuitement sur Maths-forum !

Créé un compte en 1 minute et pose ta question dans le forum ;-)
Inscription gratuite

Identification

Pas encore inscrit ?

Ou identifiez-vous :

Inscription gratuite