optimisation de macro existante

[romainchu78]

Re-bonjour,
J'ai cree cette macro excel. elle permet de definir un status sur des references de pieces.
J'ai 2 colonnes A et B. En A la provenance des references et en B la reference.
Les references proviennent de 2 sources differentes donc il y a deux types de valeurs dans la colonne A.

Le but: Dire si chacune des references issuent issue de la source "vpm" sont aussi presentent dans la source "doc". Si c'est le cas, mettre un mot el colonne C sur la meme ligne de la reference concernee et mettre de la couleur sur la ligne concernee.

ma macro fonctionne. le probleme est qu'elle n'est pas optimisee et la compilation prend 10 ou 15 min pour plus de 16000 lignes a compiler.

Quelqu'un peut-il m'aider a l'obtimiser.

Sub test()
Application.ScreenUpdating = False
For I = 1 To Range("B1").End(xlDown).Row
If Cells(I, 1).Value = "" Then
GoTo fin
End If
For J = I + 1 To Range("B1").End(xlDown).Row
If Cells(I, 2).Value = Cells(J, 2).Value And Cells(I, 1).Value = "vpm" Then
Cells(I, 2).Font.ColorIndex = 50
Cells(I, 3).Value = "|"
Cells(I, 4).Value = "In DocQuest"
GoTo FIN2
End If
Next J
FIN2:
Next I
fin:
Application.ScreenUpdating = True
End Sub


Merci par avance

 

[MJ13]

Re : optimisation de macro existante

Bonjour,

Si tu faisais un tri sur ta deuxième colonne, ne serait-ce pas plus facile.
Tu pourrais ajouter une colonne au début avec l'ordre du départ puis ainsi tu pourrais revenir à ton ordre du début.

 

[JYLL]

Re : optimisation de macro existante

Bonsoir RoaminChu, MJ13 et le Forum,

Voici la macro rémaniée. Elle copie les données dans un tableau et met le résultat dans un autre qui à la fin est copié dans la feuille. jste la fonction couleur de l'écriure ne fonctionne pas.

Testé avec un Athlon 64 3GHz temps 30 secondes.

Sub test()
  Dim Tablo() As Variant, I As Integer, J As Integer
  Tablo() = Range("A1:B" & Range("B1").End(xlDown).Row)
  Application.ScreenUpdating = False
  ReDim Résultats(UBound(Tablo, 1), 1)
  For I = 1 To UBound(Tablo, 1)
    For J = I + 1 To UBound(Tablo, 1)
      If Tablo(I, 2) = Tablo(J, 2) And Tablo(I, 1) = "vpm" Then
'Cells(I, 2).Font.ColorIndex = 28
        Résultats(I, 0) = "|"
        Résultats(I, 1) = "In DocQuest"
       GoTo FIN2
     End If
   Next J
  FIN2:
  Next I
fin:
Range("C1:" & Range("B1").End(xlDown).Row) = Résultats
Application.ScreenUpdating = True
End Sub

Bon test.

 

[romainchu78]

Re : optimisation de macro existante

jai un message d'erreur a partir de 2 min de compil surune liste de 16000 lignes.
probleme sur la ligne:
Range("C1:" & Range("B1").End(xlDown).Row) = Résultats

merci pour ton aide

 

[JYLL]

Re : optimisation de macro existante

Re bonsoir Romain,

Le problème vient de cette ligne, en voulant effacer le petit bonhomme vert que met l'interpréteur du Forum, j'ai tout simplement oublié de remettre la lettre voir exemple ci dessous. Enlever l'espace devant le D;

Range("C1😀" & Range("B1").End(xlDown).Row) = Résultats

[FONT=Comic Sans MS][COLOR=black]Range("C1: [COLOR=red]D[/COLOR]" & Range("B1").End(xlDown).Row) = Résultats[/COLOR][/FONT]

Bon test.

 

[Catrice]

Re : optimisation de macro existante

Bonsoir,

Ci-joint une interprétation de ce que j'ai compris :

Sub Test1()
Set MaZone = Range("B1:" & Range("B65536").End(xlUp).Address)
For Each X In MaZone
If X.Offset(0, -1) = "vpm" Then
Set c = Range(Cells(X.Row + 1, X.Column), Cells(MaZone.Rows.Count, X.Column)).Find(X)
If Not c Is Nothing Then
X.Font.ColorIndex = 50
X.Offset(0, 1) = "|"
X.Offset(0, 2) = "In DocQuest"
End If
End If
Next
End Sub

ou bien

Sub Test2()
For Each X In Range("B1:" & Range("B65536").End(xlUp).Address)
If X.Offset(0, -1) = "vpm" Then
Set c = Range(X.Offset(1, 0).Address, X.Offset(1, 0).End(xlDown)).Find(X)
If Not c Is Nothing Then
X.Font.ColorIndex = 50
X.Offset(0, 1) = "|"
X.Offset(0, 2) = "In DocQuest"
End If
End If
Next
End Sub

 

[JYLL]

Re : optimisation de macro existante

Re Bonsoir Romain, MJ13, Catrice et le Forum,

Bravo catrice ton algo est plus rapide que le mien (Y a pas photo) et de plus il m'a permis de vérifier que j'avais une erreur dans mon code. j'avais oublié que le tableau commencait à l'indice 0 et du coup mes résultats étaient décalés d'une ligne. Il me fallait modifier la ligne de cette façon :

ReDim Résultats(1 To UBound(Tablo, 1), 1)

Bonne soirée et merci pour la macro.

Chez moi aussi la macro test1 est plus rapide, moins de 5 secondes sur un Athlon 64 3GHz et 1 Go de mémoire. Chapeau Catrice.

 

[Catrice]

Re : optimisation de macro existante

Merci Jyll 😉

Romain, 11s pour 19000 lignes sur un celeron 2Ghz ...
Test1 est plus rapide que Test2 chez moi...