Optimisation Code Résolu

Question

Bonjour tout le monde ! 

Je viens à vous car j'ai quelques soucis pour optimiser ma petite macro. Actuellement je réussis à la faire tourner sur 18000 lignes en environ 300s. Seulement je n'ai pas 18000 données à traiter mais 150.000 et la, c'est fichtrement plus long. Donc pouvez-vous m'aider s'il vous plaît ?

Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
Option Explicit
 
Sub GestionDuTout()

Dim Debut As Currency, Fin As Currency, Freq As Currency
QueryPerformanceCounter Debut

Sheets("Feuil4").Cells.ClearContents
    Sheets("Feuil5").Cells.ClearContents
    'selection.ClearContents
    
    'MsgBox ("Suppression effectué")

'GESTION DES DOUBLONS ET MISE EN PLACE DES IDENTIFIANTS

Dim TableauDestination() As String, TableauIdentifiant() As String, TableauValeurIdentifiant() As String, TableauValeurSource() As String, TableauTargetSource() As String
    Dim TableauIdSource() As String, TableauIdentifiantTarget() As String, TableauDestinationTarget() As String, CompteurLigneDif() As String
    Dim derniere_ligne As Long, derniere_ligne2 As Long, derniere_colonne As Long, Comparateur6 As String, Comparateur5 As String, ComparateurInstituts1 As String, ComparateurInstituts2 As String, derniere_ligne3 As Long
    Dim Verification  As Boolean, Verification2 As Boolean, Verification3 As Boolean, Verif As Boolean
    
    Dim Comparateur1 As String, Comparateur2 As String, Comparateur3  As String, Comparateur4 As String, Test As String
    Dim j As Long, i As Long, w As Long, n As Long, u As Long, b As Long, h As Long, t As Long
    Dim k As Long, l As Long, m As Long, a As Long, o As Long, f As Long, ComparNum2 As Long, ComparNum1 As Long
    a = 1
    n = 1
    k = 1
    o = 1
    f = 1
    h = 1
    w = 2

derniere_ligne = Sheets("Feuil2").Range("A1").End(xlDown).Row
    derniere_colonne = Sheets("Feuil3").Range("H3").End(xlDown).Row

Dim Ws_Feuille_comparaison As Worksheet
    Set Ws_Feuille_comparaison = ThisWorkbook.Worksheets("Feuil3")
    
    Dim Ws_Feuille_destination As Worksheet
    Set Ws_Feuille_destination = ThisWorkbook.Worksheets("Feuil2")
    
    Dim Ws_feuille_Gephi As Worksheet
    Set Ws_feuille_Gephi = ThisWorkbook.Worksheets("Resultats")
    
    Dim Ws_Feuille_Identifiant As Worksheet
    Set Ws_Feuille_Identifiant = ThisWorkbook.Worksheets("Feuil4")
    
    Dim Ws_Feuille_Source As Worksheet
    Set Ws_Feuille_Source = ThisWorkbook.Worksheets("Feuil5")

'On va entrer les instituts que l'on étudie au début du tableau. Cela nous permettra de gérer plus facilement les
'target par la suite

Ws_Feuille_Identifiant.Cells(1, 1) = "Id"
    Ws_Feuille_Identifiant.Cells(1, 2) = "Label"
    Ws_Feuille_Source.Cells(1, 1) = "Source"
    Ws_Feuille_Source.Cells(1, 2) = "Target"
    Ws_Feuille_Source.Cells(1, 3) = "Weight"

For i = 2 To derniere_colonne - 1
    Ws_Feuille_Identifiant.Cells(i, 2) = Ws_Feuille_comparaison.Cells(i + 1, 7) + ", " + Ws_Feuille_comparaison.Cells(i + 1, 8)
    Ws_Feuille_Identifiant.Cells(i, 1) = i
Next

derniere_ligne3 = Sheets("Feuil4").Range("A1").End(xlDown).Row

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'GESTION DES TARGETS
                                                
derniere_ligne3 = derniere_colonne + 1

'Essaie

derniere_ligne = 17710

'Création des tableaux dynamique virtuelle pour gagner du temps dans le traitement

ReDim TableauIdentifiant(derniere_ligne)
ReDim TableauDestination(derniere_ligne)
ReDim TableauValeurIdentifiant(derniere_ligne)
ReDim TableauDestinationTarget(derniere_ligne)

For i = 1 To derniere_ligne
    TableauDestination(i) = Ws_Feuille_destination.Cells(i, 6)
    TableauDestinationTarget(i) = Ws_Feuille_destination.Cells(i, 7) '
Next
    
For i = 1 To derniere_ligne
    TableauValeurIdentifiant(i) = Ws_Feuille_Identifiant.Cells(i + 1, 1)
    TableauIdentifiant(i) = Ws_Feuille_Identifiant.Cells(i + 1, 2)
Next

'Premiere partie de code permettant de gérer les doublons.

'MsgBox (derniere_ligne3)
For j = 1 To derniere_ligne   'Va chercher l'instituts a transferer vers la colonne sans doublon
    Verification = True
    For i = 1 To derniere_ligne3    'Regarde si il n'y a pas de doublon déjà présent
    'MsgBox ("j = " & j & " Comparant : " & LCase(TableauDestination(j)) & "        " & "Comparer : " & LCase(TableauIdentifiant(i)))
        If LCase(TableauIdentifiant(i)) = LCase(TableauDestination(j)) And Verification = True Then
            Verification = False
        ElseIf LCase(TableauIdentifiant(i)) = "" And Verification = True Then
            TableauIdentifiant(i) = TableauDestination(j)
            TableauValeurIdentifiant(i) = i
            derniere_ligne3 = derniere_ligne3 + 1
            Verification = False
            'MsgBox (TableauIdentifiant(i))
        End If
    Next
Next

Application.ScreenUpdating = False
For i = derniere_colonne To derniere_ligne3
    Ws_Feuille_Identifiant.Cells(i, 1) = TableauValeurIdentifiant(i)
    Ws_Feuille_Identifiant.Cells(i, 2) = TableauIdentifiant(i)
Next
Application.ScreenUpdating = True
'Partie permettant de gérer les targets ainsi que les poids de chaques instituts en fonction de leur targets
 
 l = 1

ReDim TableauValeurSource(derniere_ligne)
 ReDim TableauTargetSource(derniere_ligne)
 ReDim TableauIdSource(derniere_ligne)

For i = 1 To derniere_ligne
    TableauTargetSource(i) = ""
    TableauValeurSource(i) = ""
    TableauIdSource(i) = ""
Next

n = 1
   l = 1

For i = 1 To derniere_ligne3 - 1

Verification = True
    Verification2 = True
        TableauIdSource(k) = TableauIdentifiant(i)
'        MsgBox (TableauIdSource(k))
        For j = 1 To derniere_ligne
'            Verification2 = True
            'MsgBox ("Instituts Comparer : " & Ws_Feuille_Identifiant.Cells(i, 1) & " Instituts comparant : " & Ws_Feuille_destination.Cells(j, 6))
            If LCase(TableauIdentifiant(i)) = LCase(TableauDestination(j)) Then
                If TableauTargetSource(k) = "" And Verification = True Then

TableauTargetSource(k) = TableauDestinationTarget(j)
                    TableauValeurSource(k) = 1
                    
                ElseIf LCase(TableauTargetSource(k)) = LCase(TableauDestinationTarget(j)) Then
                    h = TableauValeurSource(k)
                    h = h + 1
                    TableauValeurSource(k) = h

'MsgBox ("Ca marche2")
                ElseIf LCase(TableauTargetSource(k)) <> LCase(TableauDestinationTarget(j)) And Verification2 = True Then
        '            For a = l To n
        '                Verification = True
        '                If TableauTargetSource(a) = TableauTargetSource(k) Then
                            Verification = False
                            Verification2 = False
        '                End If
        '                If Verification = True Then
                            k = k + 1
                            TableauIdSource(k) = TableauIdentifiant(i)
                            TableauTargetSource(k) = TableauDestinationTarget(j)
                            TableauValeurSource(k) = 1
        '                    n = n + 1
        '                End If
        '            Next
                End If
            End If
        Next
        l = n
        'MsgBox ("Ca marche")
        k = k + 1
Next

derniere_ligne2 = Sheets("Feuil5").Range("A1").End(xlDown).Row
'MsgBox (derniere_colonne)

'Cette partie permet de convertir les noms des ID en un langage lisible par Gephi, des numéros. Chaque instituts a son propre
'numéro et c'est ce qu'on affichera au final

For i = 2 To derniere_ligne
    For j = 2 To derniere_colonne - 1
        'MsgBox ("Comparant : " & LCase(Ws_Feuille_Identifiant.Cells(i, 2)) & "    Comparer : " & LCase(Ws_Feuille_Source.Cells(i, 2)))
        If LCase(TableauTargetSource(i)) = LCase(TableauIdentifiant(j)) Then
            TableauTargetSource(i) = j - 1
        End If
    Next
Next

For i = 2 To derniere_ligne
    For j = 1 To derniere_ligne3
       If LCase(TableauIdSource(i)) = LCase(TableauIdentifiant(j)) Then
            TableauIdSource(i) = j
        End If
    Next
Next

For i = 2 To derniere_ligne
    For j = 1 To derniere_ligne3
       If LCase(TableauTargetSource(i)) = LCase(TableauIdentifiant(j)) Then
            TableauTargetSource(i) = j
        End If
    Next
Next

Application.ScreenUpdating = False

For i = 1 To k
    Ws_Feuille_Source.Cells(i + 1, 1) = TableauIdSource(i)
    Ws_Feuille_Source.Cells(i + 1, 2) = TableauTargetSource(i)
    Ws_Feuille_Source.Cells(i + 1, 3) = TableauValeurSource(i)
Next

Application.ScreenUpdating = True

QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
MsgBox "Traitement effectué en " & Format(((Fin - Debut) / Freq), "0.00") & " s"
End Sub


Merci d'avance à ceux qui m'aiderons !

michel_m · Answer

Bonjour 
Difficile de rentrer dans "le pourquoi du omment" vu la complexité

Déjà
 place Application.screenupdating=false en début de code, pas besoin de le remettre à False en fin de macro

tu peux effectivement gagner pas de temps en supprimant des boucles. Evite au maximum des cellules en boucle particulièrement chronophages

en piochant un peu par hasard dans ton code:
For i = 1 To derniere_ligne    TableauDestination(i) = Ws_Feuille_destination.Cells(i, 6)    TableauDestinationTarget(i) = Ws_Feuille_destination.Cells(i, 7) 'Next
deviendrait
TableauDestination=application.transpose(range("F1:F" & dernière ligne)) 
transpose permettant la création d'une variable tableau à une dimension+ facile à manier 

pour restituer
 Ws_Feuille_Identifiant.Cells(i, 1) = TableauValeurIdentifiant(i)à remplacer parWs_Feuille_Identifiant.range("A1").resize(ubound(TableauValeurIdentifiant),1)=application.transpose(TableauValeurIdentifiant)
Les variables-tableaux à 1 dimension sont en quelque sorte "horizontaux" d'où encore le "transpose"
--

En ce qui concerne la présence d'une donnée d'un tableau dans un autre, tu as un outil magique qui est l'objet "Dictionary". je cherche dans mon grenier un exemple d'utilisation dans la comparaison    de 2 colonnes et te le mettrais en pJ
 Michel

pijaku · Answer

Bonjour,

Je rejoins Michel, que je salue au passage, sur deux points :
1- beaucoup de boucles pas forcément très utiles, exemple cette boucle peut directement être supprimée :
For i = 1 To derniere_ligne
    TableauTargetSource(i) = ""
    TableauValeurSource(i) = ""
    TableauIdSource(i) = ""
Next
2- L'utilisation de l'objet Dictionary va te permettre de gérer directement les doublons sans double boucles.

Par contre, attention avec la fonction Transpose qui est limitée à 65 536 "lignes". Ici tu parles de 150 000, il faudra s'en passer...

Si tu peux simplement nous décrire les actions que doit réaliser ta macro.

Frabian · Answer

En premier lieux, merci à vous deux, pour le temps que vous m'accordez et pour la gentillesse de vos réponses.

En ce moment le programme tourne et il me faut des premiers résultats pour ce début d'après-midi donc je testerai vos propositions en milieux d'après midi.

Pour la fonction transpose, je ne la connaissais pas, même après avoir rechercher comment enregistrer mes tableaux plus rapidement. J'avais essayé d'utiliser la fonction Tableau = Columns("F").Value mais j'avais une erreur plus loin.

Je vais essayé d'apporter beaucoup plus de précision mais n'ayant pas l'habitude de faire ça, je m'excuse d'avance pour les oublies qu'il y aura.

1) J'ai dans une colonne des phrases( beaucoup de phrase !!) et je veux pouvoir les exporter vers une autre colonne sans doublon. C'est mon premier bout de code qui fait ça. C'est pour ça que je n'ai pas utiliser la fonction "dictionary" car il me semble que c'est uniquement pour des mots seul.
En résumé, le premier point me permet de gérer les phrases doublons. Pour cela, j'avais pensé passer par les fonction "each" car j'avais lu que c'était plus rapide mais je n'y suis pas arrivé. 

2) A côté de la première colonne, j'en ai une autre, des noms d'auteurs en réalité. Et donc je peux avoir de temps en temps la même phrase mais avec un nom d'auteur différent. Ainsi, dans une autre feuille (et ça c'est impératif si je veux pouvoir exploiter mes résultats par la suite), il faut que j'ai, sur une même ligne, la phrase (colonne A), l'auteur (colonne B) et le nombre de fois que l'auteur à répéter la phrase (colonne C). Petite info qui est peut être utile, les phrases sont trier par auteurs ! 

En tout cas je vous remercie énormément, avec ce que vous m'avais donné, je vais pouvoir bien avancer

pijaku · Answer

Bonjour,

@ Frabian : 1,8 secondes pour 151 770 lignes c'est très impressionnant en effet. Merci de ton retour à ce sujet.
En ce qui concerne l'élément de séparation, effectivement si présence de tiret dans les données initiales, il convient de changer deux lignes de codes pour que cela fonctionne.
Ref = T_in(Cptr, 1) & "-" & T_in(Cptr, 2)
'....
'et
'....
Separe = Split(T_phrase_auteur(Cptr), "-")
En remplaçant le "-" par ce que tu veux.

Si le sujet est résolu, il t'appartient de le fermer maintenant, en cliquant sur le lien "marquer comme résolu" dans ton premier message.

@ Michel : Le test If Not Dico.exists(Ref) Then n'est pas nécessaire. L'objet Dictionary, contrairement à une collection, ne plante ni en présence de doublon, ni lorsqu'il n'existe pas.
Dans le cas présent, on peut donc remplacer :
For Cptr = 1 To UBound(T_in)
    'concaténète
    Ref = T_in(Cptr, 1) & "-" & T_in(Cptr, 2)
    If Not Dico.exists(Ref) Then
        'inédit et nombre=1
        Dico.Add Ref, 1
    Else
        'incrémentation du nombre de doublons
        Dico.Item(Ref) = Dico.Item(Ref) + 1
    End If
Next
par :
For Cptr = 1 To UBound(T_in)
    Ref = T_in(Cptr, 1) & "-" & T_in(Cptr, 2)
    'Incrémentation du nombre de doublons
    Dico.Item(Ref) = Dico.Item(Ref) + 1
Next
Le test If n'étant pas chronophage, le gain de temps en soi est minime (de l'ordre de 0,3-0,4 secondes pour 150 000 lignes). C'est surtout ici plutôt de l'ordre esthétique ;-)

Optimisation Code

4 réponses

Votre réponse

Discussions similaires