Comprendre macro

Le 21/07/2023 à 14:39

bonjour,

je cherche à comprendre cette macro quelqu'un de ma société a mis en place cette outil mais ne fonctionne pas du tout j'aimerais comprendre les étapes une part une et la faire évoluer avec des couleurs et un tableau...
je vous envoie tous les codes de cette macro et le fichier Excel.

Sub EcritNoDepart()
For Each c In [départ]
If c <> "" Then ecritShape "fr-" & c, c.Offset(, 2) & Chr(10) & c
Next c
c = "54": ecritShape "fr-" & c, "Meurthe-" & Chr(10) & "Moselle", "Bas"
c = "90": ecritShape "fr-" & c, "TB"
c = "192": ecritShape "fr-" & c, "Hauts-Seine", , "Gauche"
c = "175": ecritShape "fr-" & c, "Paris"
c = "193": ecritShape "fr-" & c, "Seine-st-Denis"
c = "194": ecritShape "fr-" & c, "Val de Marne"
End Sub
Sub coloriage()
For Each c In [départ]
If c <> "" Then
ca = c.Offset(, 1)
p = Application.Match(ca, [légende], 0)
If Not IsError(p) Then
couleur = Range("légende").Cells(p, 1).Interior.Color

End If
End If
Next c
End Sub
Sub ecritShape(nomShape, Libellé, Optional posVert, Optional posHoriz)
Application.Volatile
With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
.Characters.Text = Libellé
.Characters.Font.Size = 6
If IsMissing(posVert) Then
.Parent.VerticalAnchor = msoAnchorMiddle
Else
If posVert = "Bas" Then
.Parent.VerticalAnchor = msoAnchorBottom
Else
.Parent.VerticalAnchor = msoAnchorMiddle
End If
End If
If IsMissing(posHoriz) Then
.Parent.HorizontalAnchor = msoAnchorCenter
Else
If posHoriz = "Gauche" Then
.Parent.HorizontalAnchor = msoAnchorNone
Else
.Parent.HorizontalAnchor = msoAnchorCenter
End If
End If
End With
End Sub
Sub bulles()
For Each s In ActiveSheet.Shapes
If s.Type <> 8 Then
ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
tmp = Mid(s.Name, 4)
bulle = Application.VLookup(tmp, [departca], 2, False)
If Not IsError(bulle) Then
libdep = Application.VLookup(tmp, [departca], 3, False)
s.Hyperlink.ScreenTip = libdep & " Ca:" & Format(bulle, "# ##0") & Chr(10)
Else
s.Hyperlink.ScreenTip = "...."
End If
End If
Next s
End Sub
Sub maj()
coloriage
bulles
End Sub
Sub auto()
Application.Calculation = xlAutomatic
End Sub
Sub manuel()
Application.Calculation = xlManual
End Sub
Sub ListShapes()
i = 2
For Each s In ActiveSheet.Shapes
Cells(i, "u") = s.Name
i = i + 1
Next s
End Sub

Merci de votre aide.

Baptiste.

12copie-de-copie-de-carte-de-france-trs-mds.xlsm (169.93 Ko)
Le 21/07/2023 à 15:53

  1. EcritNoDepart(): Cette sous-routine parcourt chaque cellule de la plage nommée "départ". Si la cellule n'est pas vide, elle appelle la sous-routine ecritShape pour écrire la valeur de la cellule dans une forme avec un nom spécifique ("fr-" suivi de la valeur de la cellule) et un format donné.
  2. coloriage(): Cette sous-routine parcourt également chaque cellule de la plage nommée "départ". Si la cellule n'est pas vide, elle recherche une valeur correspondante dans une autre plage nommée "légende" et récupère la couleur associée. Cependant, le code n'applique pas cette couleur à une forme ou une cellule dans cette sous-routine.
  3. ecritShape(nomShape, Libellé, Optionnel posVert, Optionnel posHoriz): Cette sous-routine est appelée par d'autres sous-routines pour écrire une étiquette spécifiée (Libellé) dans une forme ayant le nom donné (nomShape). Elle permet également un positionnement vertical et horizontal optionnel du texte dans la forme.
  4. bulles(): Cette sous-routine semble parcourir toutes les formes de la feuille active et leur ajoute des hyperliens. Elle extrait certaines informations des noms de formes pour les utiliser comme info-bulles des hyperliens.
  5. maj(): Cette sous-routine appelle les sous-routines coloriage et bulles, vraisemblablement pour mettre à jour les couleurs et les hyperliens sur la feuille active.
  6. auto(): Cette sous-routine définit le mode de calcul dans Excel en automatique.
  7. manuel(): Cette sous-routine définit le mode de calcul dans Excel en manuel.
  8. ListShapes(): Cette sous-routine liste les noms de toutes les formes de la feuille active dans la colonne U à partir de la ligne 2.

Ce code semble être conçu pour manipuler des formes et des hyperliens sur une feuille Excel en fonction des valeurs de la plage "départ" et d'autres données dans d'autres plages nommées ("légende" et "departca").

Voici la réponse de chatGPT, n'hésite pas a lui demander quand c'est comme ca, c'est très pratique et rapide :)

Lucas

Le 21/07/2023 à 16:33

Bonjour Baptiste,

Merci de mettre le code entre balises SVP, à l'aide du bouton

2023 06 22 09h32 31

Je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER]
qui vous aidera dans vos demandes et réponses sur ce forum et notamment :

  • Pour plus de lisibilité, utilisez la fonctionnalité </> pour insérer vos codes VBA (et si possible aussi pour vos formules Excel).

A+

Le 21/07/2023 à 17:33

bonjour Bruno,

Effectivement c'est beaucoup plus propre a lire sur le Forum...

bonjour,

je cherche à comprendre cette macro quelqu'un de ma société a mis en place cette outil mais ne fonctionne pas du tout j'aimerais comprendre les étapes une part une et la faire évoluer avec des couleurs et un tableau...
je vous envoie tous les codes de cette macro et le fichier Excel.

9copie-de-copie-de-carte-de-france-trs-mds.xlsm (169.93 Ko)
Sub EcritNoDepart()
For Each c In [départ]
If c <> "" Then ecritShape "fr-" & c, c.Offset(, 2) & Chr(10) & c
Next c
c = "54": ecritShape "fr-" & c, "Meurthe-" & Chr(10) & "Moselle", "Bas"
c = "90": ecritShape "fr-" & c, "TB"
c = "192": ecritShape "fr-" & c, "Hauts-Seine", , "Gauche"
c = "175": ecritShape "fr-" & c, "Paris"
c = "193": ecritShape "fr-" & c, "Seine-st-Denis"
c = "194": ecritShape "fr-" & c, "Val de Marne"
End Sub
Sub coloriage()
For Each c In [départ]
If c <> "" Then
ca = c.Offset(, 1)
p = Application.Match(ca, [légende], 0)
If Not IsError(p) Then
couleur = Range("légende").Cells(p, 1).Interior.Color

End If
End If
Next c
End Sub
Sub ecritShape(nomShape, Libellé, Optional posVert, Optional posHoriz)
Application.Volatile
With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
.Characters.Text = Libellé
.Characters.Font.Size = 6
If IsMissing(posVert) Then
.Parent.VerticalAnchor = msoAnchorMiddle
Else
If posVert = "Bas" Then
.Parent.VerticalAnchor = msoAnchorBottom
Else
.Parent.VerticalAnchor = msoAnchorMiddle
End If
End If
If IsMissing(posHoriz) Then
.Parent.HorizontalAnchor = msoAnchorCenter
Else
If posHoriz = "Gauche" Then
.Parent.HorizontalAnchor = msoAnchorNone
Else
.Parent.HorizontalAnchor = msoAnchorCenter
End If
End If
End With
End Sub
Sub bulles()
For Each s In ActiveSheet.Shapes
If s.Type <> 8 Then
ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
tmp = Mid(s.Name, 4)
bulle = Application.VLookup(tmp, [departca], 2, False)
If Not IsError(bulle) Then
libdep = Application.VLookup(tmp, [departca], 3, False)
s.Hyperlink.ScreenTip = libdep & " Ca:" & Format(bulle, "# ##0") & Chr(10)
Else
s.Hyperlink.ScreenTip = "...."
End If
End If
Next s
End Sub
Sub maj()
coloriage
bulles
End Sub
Sub auto()
Application.Calculation = xlAutomatic
End Sub
Sub manuel()
Application.Calculation = xlManual
End Sub
Sub ListShapes()
i = 2
For Each s In ActiveSheet.Shapes
Cells(i, "u") = s.Name
i = i + 1
Next s
End Sub
Rechercher des sujets similaires à "comprendre macro"