Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Optimiser ce projet... comment faire ?

Optimiser ce projet... comment faire ?

6 réponses
Avatar
Jey
Bonjour à tous !

Je viens chercher de l'aide non pour résoudre un pbm de code, tout
fonctionne très bien, mais pour l'optimiser...

J'ai un classeur, dans lequel j'importe chaque jour 5 fichiers .csv => ça c
bon, très rapide...

ensuite, j'ai une autre macro qui doit mettre à jour la première feuille du
classeur, 'Map', en fonction des nouvelles infos dans ces csv... Voici la
tête de la macro, abrégée :


For each system 'chaque système est représenté par une cellule dans la
feuille "Map"

Calculer la position de la cellule à modifier sur la feuille "Map" '
Fait appel à une première feuille, 'coord'

For planet = 1 to 12 'chaque système comprend 12 planètes, que je
décris en utilisant un commentaire de cellule...

Retrouver les infos concernant le titulaire de la planète et son
groupe 'fait appel à deux feuilles, "players" et "alliances"

Tester si le groupe est amical ou non 'fait appel à la
feuille "diplomatie"

Si Amical, alors couleur de la planète est bleu, sinon rouge

Garder en mémoire le contenu et la couleur de la ligne
concernant la planète[i]

Next planet

Concatener les 12 lignes pour former le commentaire final

Appliquer les paramètre de couleur pour chaque ligne

Next system


A priori, c'est simple... sauf que j'ai 150 systèmes et 12 planètes pour
chaque, soit 1800 planètes en tout, avec à chaque fois 4 ou 5 feuilles à
activer/sélectionner... ça prend en moyenne un bon 15 minutes pour mettre à
jour le classeur, et c'est pas non plus une vieille bécanne...

Existe-t-il un moyen de faire plus rapide ? Je sais que c'est pas évident de
voir ce que ça peut donner.... si besoin, je peux fournir le .xls...


Merci de votre aide !
Signaler un problème avec ce contenu

6 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
michdenis
Bonjour Jey,

Tu devrais publier l'intégralité de la ta procédure ici.

OU encore

et de préférence, ton classeur : la macro et les feuilles de données
afférentes à la macro ici : http://cjoint.com/


Salutations!


"Jey" a écrit dans le message de news: ev$w%
Bonjour à tous !

Je viens chercher de l'aide non pour résoudre un pbm de code, tout
fonctionne très bien, mais pour l'optimiser...

J'ai un classeur, dans lequel j'importe chaque jour 5 fichiers .csv => ça c
bon, très rapide...

ensuite, j'ai une autre macro qui doit mettre à jour la première feuille du
classeur, 'Map', en fonction des nouvelles infos dans ces csv... Voici la
tête de la macro, abrégée :


For each system 'chaque système est représenté par une cellule dans la
feuille "Map"

Calculer la position de la cellule à modifier sur la feuille "Map" '
Fait appel à une première feuille, 'coord'

For planet = 1 to 12 'chaque système comprend 12 planètes, que je
décris en utilisant un commentaire de cellule...

Retrouver les infos concernant le titulaire de la planète et son
groupe 'fait appel à deux feuilles, "players" et "alliances"

Tester si le groupe est amical ou non 'fait appel à la
feuille "diplomatie"

Si Amical, alors couleur de la planète est bleu, sinon rouge

Garder en mémoire le contenu et la couleur de la ligne
concernant la planète[i]

Next planet

Concatener les 12 lignes pour former le commentaire final

Appliquer les paramètre de couleur pour chaque ligne

Next system


A priori, c'est simple... sauf que j'ai 150 systèmes et 12 planètes pour
chaque, soit 1800 planètes en tout, avec à chaque fois 4 ou 5 feuilles à
activer/sélectionner... ça prend en moyenne un bon 15 minutes pour mettre à
jour le classeur, et c'est pas non plus une vieille bécanne...

Existe-t-il un moyen de faire plus rapide ? Je sais que c'est pas évident de
voir ce que ça peut donner.... si besoin, je peux fournir le .xls...


Merci de votre aide !
Avatar
Jey
Oki mais bon je préviens c'est long =)

Sub MAJ_sys()

Dim findrange As Range
Dim findcell As Range
Dim rangeplanet As Range
Sheets("map").Select
x_centre = Range("A1").Value
y_centre = Range("A2").Value


Sheets("variables").Select

With ActiveSheet
Set findrange = .Range("A2:A300")
End With

For Each findcell In findrange
If findcell.Value <> "" Then
abscisse = 22 - x_centre + findcell.Value
ordonnee = 29 - y_centre + findcell.Offset(0, 1).Value
idplanet = findcell.Offset(0, 3).Value
nameplanet = findcell.Offset(0, 4).Value

'cherche dans la feuille planète le nom et l'alliance du joueur sur
chaque planète
couleursys = 12
For planet = 1 To 12
On Error Resume Next
ownerid = 0
siege = 0
Sheets("planets").Select
Set rangeplanet = Selection.Range("A1:F6000")
rangeplanet.AutoFilter field:=2, Criteria1:=planet
Columns("A:A").Select

ownerid = Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
4).Value
If Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
5).Value <> 0 Then siege = 1
Sheets("player").Select
Columns("C:C").Select
Select Case ownerid
Case 0
namepl = ""
numalli = 0
Case 2
namepl = "Unknown"
numalli = 0
Case Else
namepl = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
9).Value
numalli = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
8).Value
End Select
Sheets("alliances").Select
Columns("A:A").Select
If numalli = 0 Then namealli = "" Else: namealli = "[" &
Selection.Find(what:=numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"

'Récupération du statut diplomatique
Sheets("diplomatie").Select
Columns("B:B").Select
If Selection.Find(what:=namealli, lookat:=xlWhole) Is Nothing Then
diplo = 0
Else: diplo = Selection.Find(what:=namealli,
lookat:=xlWhole).Offset(0, 4).Value
End If

'Détermination de la couleur de la ligne
If namealli = "FFA" Then couleur = 4
Select Case diplo
Case Is = "NAP"
couleur = 5
Case Is = "Ennemis"
couleur = 9
Case Else
couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If siege = 0 Then
ligne = "id" & planet & " = " & namepl & " " & namealli & vbLf
Else: ligne = planet & " = " & namepl & " " & namealli & " /S" &
vbLf
End If

Select Case planet
Case Is = 1
ligne1 = ligne
len1 = Len(ligne1)
couleur1 = couleur
Case Is = 2
ligne2 = ligne
len2 = Len(ligne2)
couleur2 = couleur
Case Is = 3
ligne3 = ligne
len3 = Len(ligne3)
couleur3 = couleur
Case Is = 4
ligne4 = ligne
len4 = Len(ligne4)
couleur4 = couleur
Case Is = 5
ligne5 = ligne
len5 = Len(ligne5)
couleur5 = couleur
Case Is = 6
ligne6 = ligne
len6 = Len(ligne6)
couleur6 = couleur
Case Is = 7
ligne7 = ligne
len7 = Len(ligne7)
couleur7 = couleur
Case Is = 8
ligne8 = ligne
len8 = Len(ligne8)
couleur8 = couleur
Case Is = 9
ligne9 = ligne
len9 = Len(ligne9)
couleur9 = couleur
Case Is = 10
ligne10 = ligne
len10 = Len(ligne10)
couleur10 = couleur
Case Is = 11
ligne11 = ligne
len11 = Len(ligne11)
couleur11 = couleur
Case Is = 12
ligne12 = ligne
len12 = Len(ligne12)
couleur12 = couleur
End Select
Next planet

ligne0 = "ID: " & idplanet & " - " & nameplanet & vbLf
len0 = Len(ligne0)

'insertion du commentaire et mise en forme
Sheets("map").Select
Cells(ordonnee, abscisse).Select
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Height = 140
.Comment.Shape.Width = 140
.Comment.Text _
Text:=ligne0 & ligne1 & ligne2 & ligne3 & ligne4 & ligne5 & ligne6 _
& ligne7 & ligne8 & ligne9 & ligne10 & ligne11 & ligne12
.Comment.Shape.TextFrame.Characters(1, len0).Font.Bold = True
.Comment.Shape.TextFrame.Characters(len0, len1).Font.ColorIndex =
couleur1
.Comment.Shape.TextFrame.Characters(len0 + len1, len2).Font.ColorIndex =
couleur2
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2,
len3).Font.ColorIndex = couleur3
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3,
len4).Font.ColorIndex = couleur4
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4,
len5).Font.ColorIndex = couleur5
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5, len6).Font.ColorIndex = couleur6
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6, len7).Font.ColorIndex = couleur7
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7, len8).Font.ColorIndex = couleur8
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8, len9).Font.ColorIndex = couleur9
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9, len10).Font.ColorIndex = couleur10
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10, len11).Font.ColorIndex = couleur11
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10 + len11, len12).Font.ColorIndex =
couleur12


End With

End If
Next findcell


End Sub





"michdenis" a écrit dans le message de news:
e$
Bonjour Jey,

Tu devrais publier l'intégralité de la ta procédure ici.

OU encore

et de préférence, ton classeur : la macro et les feuilles de données
afférentes à la macro ici : http://cjoint.com/


Salutations!


"Jey" a écrit dans le message de news:
ev$w%
Bonjour à tous !

Je viens chercher de l'aide non pour résoudre un pbm de code, tout
fonctionne très bien, mais pour l'optimiser...

J'ai un classeur, dans lequel j'importe chaque jour 5 fichiers .csv => ça
c
bon, très rapide...

ensuite, j'ai une autre macro qui doit mettre à jour la première feuille
du
classeur, 'Map', en fonction des nouvelles infos dans ces csv... Voici la
tête de la macro, abrégée :


For each system 'chaque système est représenté par une cellule dans la
feuille "Map"

Calculer la position de la cellule à modifier sur la feuille "Map"
'
Fait appel à une première feuille, 'coord'

For planet = 1 to 12 'chaque système comprend 12 planètes, que
je
décris en utilisant un commentaire de cellule...

Retrouver les infos concernant le titulaire de la planète et
son
groupe 'fait appel à deux feuilles, "players" et "alliances"

Tester si le groupe est amical ou non 'fait appel à la
feuille "diplomatie"

Si Amical, alors couleur de la planète est bleu, sinon rouge

Garder en mémoire le contenu et la couleur de la ligne
concernant la planète[i]

Next planet

Concatener les 12 lignes pour former le commentaire final

Appliquer les paramètre de couleur pour chaque ligne

Next system


A priori, c'est simple... sauf que j'ai 150 systèmes et 12 planètes pour
chaque, soit 1800 planètes en tout, avec à chaque fois 4 ou 5 feuilles à
activer/sélectionner... ça prend en moyenne un bon 15 minutes pour mettre
à
jour le classeur, et c'est pas non plus une vieille bécanne...

Existe-t-il un moyen de faire plus rapide ? Je sais que c'est pas évident
de
voir ce que ça peut donner.... si besoin, je peux fournir le .xls...


Merci de votre aide !





Avatar
michdenis
Bonjour Jey,

Essaie ceci :

Ceci n'est pas testé...évidemment !

Il y a probablement moyen de réorganiser le "Long select case"...

Attention aux coupures de ligne faites par le service de messagerie.
'---------------------------
Sub MAJ_sys()

Dim FindRange As Range
Dim FindCell As Range
Dim RangePlanet As Range
Dim X_Centre As Double, Abscisse As Double
Dim Y_Centre As Double, Ordonnee As Double
Dim IdPlanet As String, NamePlanet As String
Dim CouleurSys As Integer, Planet As Integer
Dim OwneRid As Double, Siege As Double
Dim NamePl As String, Numalli As Double
Dim NameAlli As String, Diplo As Double, Ligne As String
Dim Ligne1 As String, Ligne2 As String, Ligne3 As String, Ligne4 As String
Dim Ligne5 As String, ligne6 As String, Ligne7 As String, ligne8 As String
Dim Ligne9 As String, Ligne10 As String, Ligne11 As String, Ligne12 As String
Dim Len1 As Integer, Len2 As Integer, Len3 As Integer, Len4 As Integer, Len5 As Integer
Dim Len6 As Integer, Len7 As Integer, Len8 As Integer, Len9 As Integer, Len10 As Integer
Dim Len11 As Integer, Len12 As Integer
Dim Couleur1 As Integer, Couleur2 As Integer, Couleur3 As Integer, Couleur4 As Integer
Dim Couleur5 As Integer, Couleur6 As Integer, Couleur7 As Integer, Couleur8 As Integer
Dim Couleur9 As Integer, Couleur10 As Integer, Couleur11 As Integer, Couleur12 As Integer
Dim Len0 As Integer, Ligne0 As String


With Sheets("map")
X_Centre = Range("A1").Value
Y_Centre = Range("A2").Value
End With

With Sheets("variables")
Set FindRange = .Range("A2:A300").SpecialCells(xlCellTypeConstants)
End With

Set RangePlanet = Sheets("planets").Range("A1:F6000")

For Each FindCell In FindRange
Abscisse = 22 - X_Centre + FindCell.Value
Ordonnee = 29 - Y_Centre + FindCell.Offset(0, 1).Value
IdPlanet = FindCell.Offset(0, 3).Value
NamePlanet = FindCell.Offset(0, 4).Value
'cherche dans la feuille planète le nom et l'alliance du joueur sur chaque planète
CouleurSys = 12
For Planet = 1 To 12
On Error Resume Next
OwneRid = 0
Siege = 0
RangePlanet.AutoFilter field:=2, Criteria1:=Planet
With RangePlanet.Columns(1).EntireColumn
OwneRid = .Find(what:=IdPlanet, lookat:=xlWhole).Offset(0, 4).Value
If .Find(what:=IdPlanet, lookat:=xlWhole).Offset(0, 5).Value <> 0 Then Siege = 1
End With
With Sheets("player")
With .Columns("C:C")
Select Case OwneRid
Case 0
NamePl = ""
Numalli = 0
Case 2
NamePl = "Unknown"
Numalli = 0
Case Else
NamePl = .Find(what:=OwneRid, lookat:=xlWhole).Offset(0, 9).Value
Numalli = .Find(what:=OwneRid, lookat:=xlWhole).Offset(0, 8).Value
End Select
End With
End With
With Sheets("alliances")
With .Columns("A:A")
If Numalli = 0 Then
NameAlli = ""
Else
NameAlli = "[" & .Find(what:=Numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"
End If
End With
End With

'Récupération du statut diplomatique
With Sheets("diplomatie")
With .Columns("B:B")
If .Find(what:=NameAlli, lookat:=xlWhole) Is Nothing Then
Diplo = 0
Else
Diplo = .Find(what:=NameAlli, lookat:=xlWhole).Offset(0, 4).Value
End If
End With
End With

'Détermination de la couleur de la ligne
If NameAlli = "FFA" Then Couleur = 4
Select Case Diplo
Case Is = "NAP"
Couleur = 5
Case Is = "Ennemis"
Couleur = 9
Case Else
Couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If Siege = 0 Then
Ligne = "id" & Planet & " = " & NamePl & " " & NameAlli & vbLf
Else
Ligne = Planet & " = " & NamePl & " " & NameAlli & " /S" & vbLf
End If
End If

Select Case Planet
Case Is = 1
Ligne1 = Ligne
Len1 = Len(Ligne1)
Couleur1 = Couleur
Case Is = 2
Ligne2 = Ligne
Len2 = Len(Ligne2)
Couleur2 = Couleur
Case Is = 3
Ligne3 = Ligne
Len3 = Len(Ligne3)
Couleur3 = Couleur
Case Is = 4
Ligne4 = Ligne
Len4 = Len(Ligne4)
Couleur4 = Couleur
Case Is = 5
Ligne5 = Ligne
Len5 = Len(Ligne5)
Couleur5 = Couleur
Case Is = 6
ligne6 = Ligne
Len6 = Len(ligne6)
Couleur6 = Couleur
Case Is = 7
Ligne7 = Ligne
Len7 = Len(Ligne7)
Couleur7 = Couleur
Case Is = 8
ligne8 = Ligne
Len8 = Len(ligne8)
Couleur8 = Couleur
Case Is = 9
Ligne9 = Ligne
Len9 = Len(Ligne9)
Couleur9 = Couleur
Case Is = 10
Ligne10 = Ligne
Len10 = Len(Ligne10)
Couleur10 = Couleur
Case Is = 11
Ligne11 = Ligne
Len11 = Len(Ligne11)
Couleur11 = Couleur
Case Is = 12
Ligne12 = Ligne
Len12 = Len(Ligne12)
Couleur12 = Couleur
End Select
Next Planet
Ligne0 = "ID: " & IdPlanet & " - " & NamePlanet & vbLf
Len0 = Len(Ligne0)

'insertion du commentaire et mise en forme
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Visible = False
.Shape.Height = 140
.Shape.Width = 140
.Text _
Text:=Ligne0 & Ligne1 & Ligne2 & Ligne3 & Ligne4 & Ligne5 & ligne6 _
& Ligne7 & ligne8 & Ligne9 & Ligne10 & Ligne11 & Ligne12
.Shape.TextFrame.Characters(1, Len0).Font.Bold = True
.Shape.TextFrame.Characters(Len0, Len1).Font.ColorIndex = Couleur1
.Shape.TextFrame.Characters(Len0 + Len1, Len2).Font.ColorIndex = Couleur2
.Shape.TextFrame.Characters(Len0 + Len1 + Len2, Len3).Font.ColorIndex = Couleur3
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3, Len4).Font.ColorIndex = Couleur4
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4, Len5).Font.ColorIndex = Couleur5
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5, Len6).Font.ColorIndex = Couleur6
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6, Len7).Font.ColorIndex = Couleur7
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7, Len8).Font.ColorIndex = Couleur8
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7 + Len8, Len9).Font.ColorIndex =
Couleur9
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7 + Len8 + Len9,
Len10).Font.ColorIndex = Couleur10
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7 + Len8 + Len9 + Len10,
Len11).Font.ColorIndex = Couleur11
.Shape.TextFrame.Characters(Len0 + Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7 + Len8 + Len9 + Len10 + Len11,
Len12).Font.ColorIndex = Couleur12
End With
End With
End With
Next FindCell


End Sub
'---------------------------


Salutations!



"Jey" a écrit dans le message de news:
Oki mais bon je préviens c'est long =)

Sub MAJ_sys()

Dim findrange As Range
Dim findcell As Range
Dim rangeplanet As Range
Sheets("map").Select
x_centre = Range("A1").Value
y_centre = Range("A2").Value


Sheets("variables").Select

With ActiveSheet
Set findrange = .Range("A2:A300")
End With

For Each findcell In findrange
If findcell.Value <> "" Then
abscisse = 22 - x_centre + findcell.Value
ordonnee = 29 - y_centre + findcell.Offset(0, 1).Value
idplanet = findcell.Offset(0, 3).Value
nameplanet = findcell.Offset(0, 4).Value

'cherche dans la feuille planète le nom et l'alliance du joueur sur
chaque planète
couleursys = 12
For planet = 1 To 12
On Error Resume Next
ownerid = 0
siege = 0
Sheets("planets").Select
Set rangeplanet = Selection.Range("A1:F6000")
rangeplanet.AutoFilter field:=2, Criteria1:=planet
Columns("A:A").Select

ownerid = Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
4).Value
If Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
5).Value <> 0 Then siege = 1
Sheets("player").Select
Columns("C:C").Select
Select Case ownerid
Case 0
namepl = ""
numalli = 0
Case 2
namepl = "Unknown"
numalli = 0
Case Else
namepl = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
9).Value
numalli = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
8).Value
End Select
Sheets("alliances").Select
Columns("A:A").Select
If numalli = 0 Then namealli = "" Else: namealli = "[" &
Selection.Find(what:=numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"

'Récupération du statut diplomatique
Sheets("diplomatie").Select
Columns("B:B").Select
If Selection.Find(what:=namealli, lookat:=xlWhole) Is Nothing Then
diplo = 0
Else: diplo = Selection.Find(what:=namealli,
lookat:=xlWhole).Offset(0, 4).Value
End If

'Détermination de la couleur de la ligne
If namealli = "FFA" Then couleur = 4
Select Case diplo
Case Is = "NAP"
couleur = 5
Case Is = "Ennemis"
couleur = 9
Case Else
couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If siege = 0 Then
ligne = "id" & planet & " = " & namepl & " " & namealli & vbLf
Else: ligne = planet & " = " & namepl & " " & namealli & " /S" &
vbLf
End If

Select Case planet
Case Is = 1
ligne1 = ligne
len1 = Len(ligne1)
couleur1 = couleur
Case Is = 2
ligne2 = ligne
len2 = Len(ligne2)
couleur2 = couleur
Case Is = 3
ligne3 = ligne
len3 = Len(ligne3)
couleur3 = couleur
Case Is = 4
ligne4 = ligne
len4 = Len(ligne4)
couleur4 = couleur
Case Is = 5
ligne5 = ligne
len5 = Len(ligne5)
couleur5 = couleur
Case Is = 6
ligne6 = ligne
len6 = Len(ligne6)
couleur6 = couleur
Case Is = 7
ligne7 = ligne
len7 = Len(ligne7)
couleur7 = couleur
Case Is = 8
ligne8 = ligne
len8 = Len(ligne8)
couleur8 = couleur
Case Is = 9
ligne9 = ligne
len9 = Len(ligne9)
couleur9 = couleur
Case Is = 10
ligne10 = ligne
len10 = Len(ligne10)
couleur10 = couleur
Case Is = 11
ligne11 = ligne
len11 = Len(ligne11)
couleur11 = couleur
Case Is = 12
ligne12 = ligne
len12 = Len(ligne12)
couleur12 = couleur
End Select
Next planet

ligne0 = "ID: " & idplanet & " - " & nameplanet & vbLf
len0 = Len(ligne0)

'insertion du commentaire et mise en forme
Sheets("map").Select
Cells(ordonnee, abscisse).Select
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Height = 140
.Comment.Shape.Width = 140
.Comment.Text _
Text:=ligne0 & ligne1 & ligne2 & ligne3 & ligne4 & ligne5 & ligne6 _
& ligne7 & ligne8 & ligne9 & ligne10 & ligne11 & ligne12
.Comment.Shape.TextFrame.Characters(1, len0).Font.Bold = True
.Comment.Shape.TextFrame.Characters(len0, len1).Font.ColorIndex couleur1
.Comment.Shape.TextFrame.Characters(len0 + len1, len2).Font.ColorIndex couleur2
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2,
len3).Font.ColorIndex = couleur3
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3,
len4).Font.ColorIndex = couleur4
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4,
len5).Font.ColorIndex = couleur5
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5, len6).Font.ColorIndex = couleur6
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6, len7).Font.ColorIndex = couleur7
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7, len8).Font.ColorIndex = couleur8
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8, len9).Font.ColorIndex = couleur9
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9, len10).Font.ColorIndex = couleur10
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10, len11).Font.ColorIndex = couleur11
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10 + len11, len12).Font.ColorIndex couleur12


End With

End If
Next findcell


End Sub





"michdenis" a écrit dans le message de news:
e$
Bonjour Jey,

Tu devrais publier l'intégralité de la ta procédure ici.

OU encore

et de préférence, ton classeur : la macro et les feuilles de données
afférentes à la macro ici : http://cjoint.com/


Salutations!


"Jey" a écrit dans le message de news:
ev$w%
Bonjour à tous !

Je viens chercher de l'aide non pour résoudre un pbm de code, tout
fonctionne très bien, mais pour l'optimiser...

J'ai un classeur, dans lequel j'importe chaque jour 5 fichiers .csv => ça
c
bon, très rapide...

ensuite, j'ai une autre macro qui doit mettre à jour la première feuille
du
classeur, 'Map', en fonction des nouvelles infos dans ces csv... Voici la
tête de la macro, abrégée :


For each system 'chaque système est représenté par une cellule dans la
feuille "Map"

Calculer la position de la cellule à modifier sur la feuille "Map"
'
Fait appel à une première feuille, 'coord'

For planet = 1 to 12 'chaque système comprend 12 planètes, que
je
décris en utilisant un commentaire de cellule...

Retrouver les infos concernant le titulaire de la planète et
son
groupe 'fait appel à deux feuilles, "players" et "alliances"

Tester si le groupe est amical ou non 'fait appel à la
feuille "diplomatie"

Si Amical, alors couleur de la planète est bleu, sinon rouge

Garder en mémoire le contenu et la couleur de la ligne
concernant la planète[i]

Next planet

Concatener les 12 lignes pour former le commentaire final

Appliquer les paramètre de couleur pour chaque ligne

Next system


A priori, c'est simple... sauf que j'ai 150 systèmes et 12 planètes pour
chaque, soit 1800 planètes en tout, avec à chaque fois 4 ou 5 feuilles à
activer/sélectionner... ça prend en moyenne un bon 15 minutes pour mettre
à
jour le classeur, et c'est pas non plus une vieille bécanne...

Existe-t-il un moyen de faire plus rapide ? Je sais que c'est pas évident
de
voir ce que ça peut donner.... si besoin, je peux fournir le .xls...


Merci de votre aide !





Avatar
Mousnynao
Bonjour,

Quelques idées d'optimisation !

Option Explicit

Type MonType
Ligne(16) As String
Longueur(16) As Long
Couleur(16) As Long
End Type

Dim CesLig As MonType
'

Sub Cible()

Dim Planet As String

'Si structure défini, alors ces lignes

CesLig.Ligne(Planet) = Ligne(0)
CesLig.Longueur(Planet) = Len(CesLig.Ligne(Planet))
CesLig.Couleur(Planet) = Couleur

'remplace celles-ci

Select Case Planet
Case Is = 1
Ligne1 = Ligne
Len1 = Len(Ligne1)
Couleur1 = Couleur
Case Is = 2
Ligne2 = Ligne
Len2 = Len(Ligne2)
Couleur2 = Couleur
Case Is = 3
Ligne3 = Ligne
Len3 = Len(Ligne3)
Couleur3 = Couleur
Case Is = 4
Ligne4 = Ligne
Len4 = Len(Ligne4)
Couleur4 = Couleur
Case Is = 5
Ligne5 = Ligne
Len5 = Len(Ligne5)
Couleur5 = Couleur
Case Is = 6
ligne6 = Ligne
Len6 = Len(ligne6)
Couleur6 = Couleur
Case Is = 7
Ligne7 = Ligne
Len7 = Len(Ligne7)
Couleur7 = Couleur
Case Is = 8
ligne8 = Ligne
Len8 = Len(ligne8)
Couleur8 = Couleur
Case Is = 9
Ligne9 = Ligne
Len9 = Len(Ligne9)
Couleur9 = Couleur
Case Is = 10
Ligne10 = Ligne
Len10 = Len(Ligne10)
Couleur10 = Couleur
Case Is = 11
Ligne11 = Ligne
Len11 = Len(Ligne11)
Couleur11 = Couleur
Case Is = 12
Ligne12 = Ligne
Len12 = Len(Ligne12)
Couleur12 = Couleur
End Select


End Sub
'
Sub LanceSomme()

'Ici la grande partie d'affectation

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
Sub LanceSomme()

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)
End With
End With
End With
Next i

End Sub
End With
End With
End With
Next i

End Sub
'

Function Sommation(Limite As Long) As Long

Dim Cmpt As Long

For Cmpt = 1 To Limite
Sommation = Sommation + CesLig.Longueur(Cmpt)
Next Cmpt


End Function

mousnynao


Oki mais bon je préviens c'est long =)

Sub MAJ_sys()

Dim findrange As Range
Dim findcell As Range
Dim rangeplanet As Range
Sheets("map").Select
x_centre = Range("A1").Value
y_centre = Range("A2").Value


Sheets("variables").Select

With ActiveSheet
Set findrange = .Range("A2:A300")
End With

For Each findcell In findrange
If findcell.Value <> "" Then
abscisse = 22 - x_centre + findcell.Value
ordonnee = 29 - y_centre + findcell.Offset(0, 1).Value
idplanet = findcell.Offset(0, 3).Value
nameplanet = findcell.Offset(0, 4).Value

'cherche dans la feuille planète le nom et l'alliance du joueur sur
chaque planète
couleursys = 12
For planet = 1 To 12
On Error Resume Next
ownerid = 0
siege = 0
Sheets("planets").Select
Set rangeplanet = Selection.Range("A1:F6000")
rangeplanet.AutoFilter field:=2, Criteria1:=planet
Columns("A:A").Select

ownerid = Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
4).Value
If Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
5).Value <> 0 Then siege = 1
Sheets("player").Select
Columns("C:C").Select
Select Case ownerid
Case 0
namepl = ""
numalli = 0
Case 2
namepl = "Unknown"
numalli = 0
Case Else
namepl = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
9).Value
numalli = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
8).Value
End Select
Sheets("alliances").Select
Columns("A:A").Select
If numalli = 0 Then namealli = "" Else: namealli = "[" &
Selection.Find(what:=numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"

'Récupération du statut diplomatique
Sheets("diplomatie").Select
Columns("B:B").Select
If Selection.Find(what:=namealli, lookat:=xlWhole) Is Nothing Then
diplo = 0
Else: diplo = Selection.Find(what:=namealli,
lookat:=xlWhole).Offset(0, 4).Value
End If

'Détermination de la couleur de la ligne
If namealli = "FFA" Then couleur = 4
Select Case diplo
Case Is = "NAP"
couleur = 5
Case Is = "Ennemis"
couleur = 9
Case Else
couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If siege = 0 Then
ligne = "id" & planet & " = " & namepl & " " & namealli & vbLf
Else: ligne = planet & " = " & namepl & " " & namealli & " /S" &
vbLf
End If

Select Case planet
Case Is = 1
ligne1 = ligne
len1 = Len(ligne1)
couleur1 = couleur
Case Is = 2
ligne2 = ligne
len2 = Len(ligne2)
couleur2 = couleur
Case Is = 3
ligne3 = ligne
len3 = Len(ligne3)
couleur3 = couleur
Case Is = 4
ligne4 = ligne
len4 = Len(ligne4)
couleur4 = couleur
Case Is = 5
ligne5 = ligne
len5 = Len(ligne5)
couleur5 = couleur
Case Is = 6
ligne6 = ligne
len6 = Len(ligne6)
couleur6 = couleur
Case Is = 7
ligne7 = ligne
len7 = Len(ligne7)
couleur7 = couleur
Case Is = 8
ligne8 = ligne
len8 = Len(ligne8)
couleur8 = couleur
Case Is = 9
ligne9 = ligne
len9 = Len(ligne9)
couleur9 = couleur
Case Is = 10
ligne10 = ligne
len10 = Len(ligne10)
couleur10 = couleur
Case Is = 11
ligne11 = ligne
len11 = Len(ligne11)
couleur11 = couleur
Case Is = 12
ligne12 = ligne
len12 = Len(ligne12)
couleur12 = couleur
End Select
Next planet

ligne0 = "ID: " & idplanet & " - " & nameplanet & vbLf
len0 = Len(ligne0)

'insertion du commentaire et mise en forme
Sheets("map").Select
Cells(ordonnee, abscisse).Select
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Height = 140
.Comment.Shape.Width = 140
.Comment.Text _
Text:=ligne0 & ligne1 & ligne2 & ligne3 & ligne4 & ligne5 & ligne6 _
& ligne7 & ligne8 & ligne9 & ligne10 & ligne11 & ligne12
.Comment.Shape.TextFrame.Characters(1, len0).Font.Bold = True
.Comment.Shape.TextFrame.Characters(len0, len1).Font.ColorIndex =
couleur1
.Comment.Shape.TextFrame.Characters(len0 + len1, len2).Font.ColorIndex =
couleur2
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2,
len3).Font.ColorIndex = couleur3
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3,
len4).Font.ColorIndex = couleur4
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4,
len5).Font.ColorIndex = couleur5
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5, len6).Font.ColorIndex = couleur6
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6, len7).Font.ColorIndex = couleur7
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7, len8).Font.ColorIndex = couleur8
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8, len9).Font.ColorIndex = couleur9
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9, len10).Font.ColorIndex = couleur10
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10, len11).Font.ColorIndex = couleur11
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7 + len8 + len9 + len10 + len11, len12).Font.ColorIndex =
couleur12


End With

End If
Next findcell


End Sub





"michdenis" a écrit dans le message de news:
e$
Bonjour Jey,

Tu devrais publier l'intégralité de la ta procédure ici.

OU encore

et de préférence, ton classeur : la macro et les feuilles de données
afférentes à la macro ici : http://cjoint.com/


Salutations!


"Jey" a écrit dans le message de news:
ev$w%
Bonjour à tous !

Je viens chercher de l'aide non pour résoudre un pbm de code, tout
fonctionne très bien, mais pour l'optimiser...

J'ai un classeur, dans lequel j'importe chaque jour 5 fichiers .csv => ça
c
bon, très rapide...

ensuite, j'ai une autre macro qui doit mettre à jour la première feuille
du
classeur, 'Map', en fonction des nouvelles infos dans ces csv... Voici la
tête de la macro, abrégée :


For each system 'chaque système est représenté par une cellule dans la
feuille "Map"

Calculer la position de la cellule à modifier sur la feuille "Map"
'
Fait appel à une première feuille, 'coord'

For planet = 1 to 12 'chaque système comprend 12 planètes, que
je
décris en utilisant un commentaire de cellule...

Retrouver les infos concernant le titulaire de la planète et
son
groupe 'fait appel à deux feuilles, "players" et "alliances"

Tester si le groupe est amical ou non 'fait appel à la
feuille "diplomatie"

Si Amical, alors couleur de la planète est bleu, sinon rouge

Garder en mémoire le contenu et la couleur de la ligne
concernant la planète[i]

Next planet

Concatener les 12 lignes pour former le commentaire final

Appliquer les paramètre de couleur pour chaque ligne

Next system


A priori, c'est simple... sauf que j'ai 150 systèmes et 12 planètes pour
chaque, soit 1800 planètes en tout, avec à chaque fois 4 ou 5 feuilles à
activer/sélectionner... ça prend en moyenne un bon 15 minutes pour mettre
à
jour le classeur, et c'est pas non plus une vieille bécanne...

Existe-t-il un moyen de faire plus rapide ? Je sais que c'est pas évident
de
voir ce que ça peut donner.... si besoin, je peux fournir le .xls...


Merci de votre aide !










Avatar
Mousnynao
re :

désolé, j'ai mal recopier !

Sub LanceSomme()

'Ici la grande partie d'affectation

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)
End With
End With
End With
Next i

End Sub
'
Dans cette ligne :

.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)

je ne suis pas sur des index, pour le [i] de [Sommation(i)] c'est
l'objectif de la manoeuvre mais pour [CesLig.Couleur(12)] à toi de valider !

mousnynao


Bonjour,

Quelques idées d'optimisation !

Option Explicit

Type MonType
Ligne(16) As String
Longueur(16) As Long
Couleur(16) As Long
End Type

Dim CesLig As MonType
'

Sub Cible()

Dim Planet As String

'Si structure défini, alors ces lignes

CesLig.Ligne(Planet) = Ligne(0)
CesLig.Longueur(Planet) = Len(CesLig.Ligne(Planet))
CesLig.Couleur(Planet) = Couleur

'remplace celles-ci

Select Case Planet
Case Is = 1
Ligne1 = Ligne
Len1 = Len(Ligne1)
Couleur1 = Couleur
Case Is = 2
Ligne2 = Ligne
Len2 = Len(Ligne2)
Couleur2 = Couleur
Case Is = 3
Ligne3 = Ligne
Len3 = Len(Ligne3)
Couleur3 = Couleur
Case Is = 4
Ligne4 = Ligne
Len4 = Len(Ligne4)
Couleur4 = Couleur
Case Is = 5
Ligne5 = Ligne
Len5 = Len(Ligne5)
Couleur5 = Couleur
Case Is = 6
ligne6 = Ligne
Len6 = Len(ligne6)
Couleur6 = Couleur
Case Is = 7
Ligne7 = Ligne
Len7 = Len(Ligne7)
Couleur7 = Couleur
Case Is = 8
ligne8 = Ligne
Len8 = Len(ligne8)
Couleur8 = Couleur
Case Is = 9
Ligne9 = Ligne
Len9 = Len(Ligne9)
Couleur9 = Couleur
Case Is = 10
Ligne10 = Ligne
Len10 = Len(Ligne10)
Couleur10 = Couleur
Case Is = 11
Ligne11 = Ligne
Len11 = Len(Ligne11)
Couleur11 = Couleur
Case Is = 12
Ligne12 = Ligne
Len12 = Len(Ligne12)
Couleur12 = Couleur
End Select


End Sub
'
Sub LanceSomme()

'Ici la grande partie d'affectation

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
Sub LanceSomme()

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)
End With
End With
End With
Next i

End Sub
End With
End With
End With
Next i

End Sub
'

Function Sommation(Limite As Long) As Long

Dim Cmpt As Long

For Cmpt = 1 To Limite
Sommation = Sommation + CesLig.Longueur(Cmpt)
Next Cmpt


End Function

mousnynao


Oki mais bon je préviens c'est long =)

Sub MAJ_sys()

Dim findrange As Range
Dim findcell As Range
Dim rangeplanet As Range
Sheets("map").Select
x_centre = Range("A1").Value
y_centre = Range("A2").Value


Sheets("variables").Select

With ActiveSheet
Set findrange = .Range("A2:A300")
End With

For Each findcell In findrange
If findcell.Value <> "" Then
abscisse = 22 - x_centre + findcell.Value
ordonnee = 29 - y_centre + findcell.Offset(0, 1).Value
idplanet = findcell.Offset(0, 3).Value
nameplanet = findcell.Offset(0, 4).Value

'cherche dans la feuille planète le nom et l'alliance du joueur sur
chaque planète
couleursys = 12
For planet = 1 To 12
On Error Resume Next
ownerid = 0
siege = 0
Sheets("planets").Select
Set rangeplanet = Selection.Range("A1:F6000")
rangeplanet.AutoFilter field:=2, Criteria1:=planet
Columns("A:A").Select

ownerid = Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
4).Value
If Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
5).Value <> 0 Then siege = 1
Sheets("player").Select
Columns("C:C").Select
Select Case ownerid
Case 0
namepl = ""
numalli = 0
Case 2
namepl = "Unknown"
numalli = 0
Case Else
namepl = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
9).Value
numalli = Selection.Find(what:=ownerid, lookat:=xlWhole).Offset(0,
8).Value
End Select
Sheets("alliances").Select
Columns("A:A").Select
If numalli = 0 Then namealli = "" Else: namealli = "[" &
Selection.Find(what:=numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"

'Récupération du statut diplomatique
Sheets("diplomatie").Select
Columns("B:B").Select
If Selection.Find(what:=namealli, lookat:=xlWhole) Is Nothing Then
diplo = 0
Else: diplo = Selection.Find(what:=namealli,
lookat:=xlWhole).Offset(0, 4).Value
End If

'Détermination de la couleur de la ligne
If namealli = "FFA" Then couleur = 4
Select Case diplo
Case Is = "NAP"
couleur = 5
Case Is = "Ennemis"
couleur = 9
Case Else
couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If siege = 0 Then
ligne = "id" & planet & " = " & namepl & " " & namealli & vbLf
Else: ligne = planet & " = " & namepl & " " & namealli & " /S" &
vbLf
End If

Select Case planet
Case Is = 1
ligne1 = ligne
len1 = Len(ligne1)
couleur1 = couleur
Case Is = 2
ligne2 = ligne
len2 = Len(ligne2)
couleur2 = couleur
Case Is = 3
ligne3 = ligne
len3 = Len(ligne3)
couleur3 = couleur
Case Is = 4
ligne4 = ligne
len4 = Len(ligne4)
couleur4 = couleur
Case Is = 5
ligne5 = ligne
len5 = Len(ligne5)
couleur5 = couleur
Case Is = 6
ligne6 = ligne
len6 = Len(ligne6)
couleur6 = couleur
Case Is = 7
ligne7 = ligne
len7 = Len(ligne7)
couleur7 = couleur
Case Is = 8
ligne8 = ligne
len8 = Len(ligne8)
couleur8 = couleur
Case Is = 9
ligne9 = ligne
len9 = Len(ligne9)
couleur9 = couleur
Case Is = 10
ligne10 = ligne
len10 = Len(ligne10)
couleur10 = couleur
Case Is = 11
ligne11 = ligne
len11 = Len(ligne11)
couleur11 = couleur
Case Is = 12
ligne12 = ligne
len12 = Len(ligne12)
couleur12 = couleur
End Select
Next planet

ligne0 = "ID: " & idplanet & " - " & nameplanet & vbLf
len0 = Len(ligne0)

'insertion du commentaire et mise en forme
Sheets("map").Select
Cells(ordonnee, abscisse).Select
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Height = 140
.Comment.Shape.Width = 140
.Comment.Text _
Text:=ligne0 & ligne1 & ligne2 & ligne3 & ligne4 & ligne5 & ligne6 _
& ligne7 & ligne8 & ligne9 & ligne10 & ligne11 & ligne12
.Comment.Shape.TextFrame.Characters(1, len0).Font.Bold = True
.Comment.Shape.TextFrame.Characters(len0, len1).Font.ColorIndex =
couleur1
.Comment.Shape.TextFrame.Characters(len0 + len1, len2).Font.ColorIndex =
couleur2
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2,
len3).Font.ColorIndex = couleur3
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3,
len4).Font.ColorIndex = couleur4
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4,
len5).Font.ColorIndex = couleur5
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5, len6).Font.ColorIndex = couleur6
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6, len7).Font.ColorIndex = couleur7
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +
len5 + len6 + len7, len8).Font.ColorIndex = couleur8
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 + len4 +




Avatar
Jey
Merci à vous, je vais tester ça ce soir...

Décidemment, je ne suis qu'un débutant en Vba, il y'a bcp de fonctions que
je ne connais pas ;)



"Mousnynao" a écrit dans le message de
news:
re :

désolé, j'ai mal recopier !

Sub LanceSomme()

'Ici la grande partie d'affectation

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)
End With
End With
End With
Next i

End Sub
'
Dans cette ligne :

.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)

je ne suis pas sur des index, pour le [i] de [Sommation(i)] c'est
l'objectif de la manoeuvre mais pour [CesLig.Couleur(12)] à toi de valider
!

mousnynao


Bonjour,

Quelques idées d'optimisation !

Option Explicit

Type MonType
Ligne(16) As String
Longueur(16) As Long
Couleur(16) As Long
End Type

Dim CesLig As MonType
'

Sub Cible()

Dim Planet As String

'Si structure défini, alors ces lignes

CesLig.Ligne(Planet) = Ligne(0)
CesLig.Longueur(Planet) = Len(CesLig.Ligne(Planet))
CesLig.Couleur(Planet) = Couleur

'remplace celles-ci

Select Case Planet
Case Is = 1
Ligne1 = Ligne
Len1 = Len(Ligne1)
Couleur1 = Couleur
Case Is = 2
Ligne2 = Ligne
Len2 = Len(Ligne2)
Couleur2 = Couleur
Case Is = 3
Ligne3 = Ligne
Len3 = Len(Ligne3)
Couleur3 = Couleur
Case Is = 4
Ligne4 = Ligne
Len4 = Len(Ligne4)
Couleur4 = Couleur
Case Is = 5
Ligne5 = Ligne
Len5 = Len(Ligne5)
Couleur5 = Couleur
Case Is = 6
ligne6 = Ligne
Len6 = Len(ligne6)
Couleur6 = Couleur
Case Is = 7
Ligne7 = Ligne
Len7 = Len(Ligne7)
Couleur7 = Couleur
Case Is = 8
ligne8 = Ligne
Len8 = Len(ligne8)
Couleur8 = Couleur
Case Is = 9
Ligne9 = Ligne
Len9 = Len(Ligne9)
Couleur9 = Couleur
Case Is = 10
Ligne10 = Ligne
Len10 = Len(Ligne10)
Couleur10 = Couleur
Case Is = 11
Ligne11 = Ligne
Len11 = Len(Ligne11)
Couleur11 = Couleur
Case Is = 12
Ligne12 = Ligne
Len12 = Len(Ligne12)
Couleur12 = Couleur
End Select


End Sub
'
Sub LanceSomme()

'Ici la grande partie d'affectation

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
Sub LanceSomme()

For i = 1 To 11
With Sheets("map")
With .Cells(Ordonnee, Abscisse)
.ClearComments
With .AddComment
.Shape.TextFrame.Characters(Sommation(i),
CesLig.Couleur(12)).Font.ColorIndex = CesLig.Couleur(12)
End With
End With
End With
Next i

End Sub
End With
End With
End With
Next i

End Sub
'

Function Sommation(Limite As Long) As Long

Dim Cmpt As Long

For Cmpt = 1 To Limite
Sommation = Sommation + CesLig.Longueur(Cmpt)
Next Cmpt


End Function

mousnynao


Oki mais bon je préviens c'est long =)

Sub MAJ_sys()

Dim findrange As Range
Dim findcell As Range
Dim rangeplanet As Range
Sheets("map").Select
x_centre = Range("A1").Value
y_centre = Range("A2").Value


Sheets("variables").Select

With ActiveSheet
Set findrange = .Range("A2:A300")
End With

For Each findcell In findrange
If findcell.Value <> "" Then
abscisse = 22 - x_centre + findcell.Value
ordonnee = 29 - y_centre + findcell.Offset(0, 1).Value
idplanet = findcell.Offset(0, 3).Value
nameplanet = findcell.Offset(0, 4).Value

'cherche dans la feuille planète le nom et l'alliance du joueur sur
chaque planète
couleursys = 12
For planet = 1 To 12
On Error Resume Next
ownerid = 0
siege = 0
Sheets("planets").Select
Set rangeplanet = Selection.Range("A1:F6000")
rangeplanet.AutoFilter field:=2, Criteria1:=planet
Columns("A:A").Select

ownerid = Selection.Find(what:=idplanet,
lookat:=xlWhole).Offset(0,
4).Value
If Selection.Find(what:=idplanet, lookat:=xlWhole).Offset(0,
5).Value <> 0 Then siege = 1
Sheets("player").Select
Columns("C:C").Select
Select Case ownerid
Case 0
namepl = ""
numalli = 0
Case 2
namepl = "Unknown"
numalli = 0
Case Else
namepl = Selection.Find(what:=ownerid,
lookat:=xlWhole).Offset(0,
9).Value
numalli = Selection.Find(what:=ownerid,
lookat:=xlWhole).Offset(0,
8).Value
End Select
Sheets("alliances").Select
Columns("A:A").Select
If numalli = 0 Then namealli = "" Else: namealli = "[" &
Selection.Find(what:=numalli, lookat:=xlWhole).Offset(0, 1).Value & "]"

'Récupération du statut diplomatique
Sheets("diplomatie").Select
Columns("B:B").Select
If Selection.Find(what:=namealli, lookat:=xlWhole) Is Nothing
Then
diplo = 0
Else: diplo = Selection.Find(what:=namealli,
lookat:=xlWhole).Offset(0, 4).Value
End If

'Détermination de la couleur de la ligne
If namealli = "FFA" Then couleur = 4
Select Case diplo
Case Is = "NAP"
couleur = 5
Case Is = "Ennemis"
couleur = 9
Case Else
couleur = 1
End Select

'préparation de la ligne de texte dans commentaire
If siege = 0 Then
ligne = "id" & planet & " = " & namepl & " " & namealli & vbLf
Else: ligne = planet & " = " & namepl & " " & namealli & " /S"
&
vbLf
End If

Select Case planet
Case Is = 1
ligne1 = ligne
len1 = Len(ligne1)
couleur1 = couleur
Case Is = 2
ligne2 = ligne
len2 = Len(ligne2)
couleur2 = couleur
Case Is = 3
ligne3 = ligne
len3 = Len(ligne3)
couleur3 = couleur
Case Is = 4
ligne4 = ligne
len4 = Len(ligne4)
couleur4 = couleur
Case Is = 5
ligne5 = ligne
len5 = Len(ligne5)
couleur5 = couleur
Case Is = 6
ligne6 = ligne
len6 = Len(ligne6)
couleur6 = couleur
Case Is = 7
ligne7 = ligne
len7 = Len(ligne7)
couleur7 = couleur
Case Is = 8
ligne8 = ligne
len8 = Len(ligne8)
couleur8 = couleur
Case Is = 9
ligne9 = ligne
len9 = Len(ligne9)
couleur9 = couleur
Case Is = 10
ligne10 = ligne
len10 = Len(ligne10)
couleur10 = couleur
Case Is = 11
ligne11 = ligne
len11 = Len(ligne11)
couleur11 = couleur
Case Is = 12
ligne12 = ligne
len12 = Len(ligne12)
couleur12 = couleur
End Select
Next planet

ligne0 = "ID: " & idplanet & " - " & nameplanet & vbLf
len0 = Len(ligne0)

'insertion du commentaire et mise en forme
Sheets("map").Select
Cells(ordonnee, abscisse).Select
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Height = 140
.Comment.Shape.Width = 140
.Comment.Text _
Text:=ligne0 & ligne1 & ligne2 & ligne3 & ligne4 & ligne5 & ligne6
_
& ligne7 & ligne8 & ligne9 & ligne10 & ligne11 & ligne12
.Comment.Shape.TextFrame.Characters(1, len0).Font.Bold = True
.Comment.Shape.TextFrame.Characters(len0, len1).Font.ColorIndex >> > couleur1
.Comment.Shape.TextFrame.Characters(len0 + len1,
len2).Font.ColorIndex >> > couleur2
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2,
len3).Font.ColorIndex = couleur3
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3,
len4).Font.ColorIndex = couleur4
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 +
len4,
len5).Font.ColorIndex = couleur5
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 +
len4 +
len5, len6).Font.ColorIndex = couleur6
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 +
len4 +
len5 + len6, len7).Font.ColorIndex = couleur7
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 +
len4 +
len5 + len6 + len7, len8).Font.ColorIndex = couleur8
.Comment.Shape.TextFrame.Characters(len0 + len1 + len2 + len3 +
len4 +