Code prend 1 heure pour afficher les resultats

cedric_hiss

XLDnaute Junior
Bonjour a tous ,

je viens de terminer un code qui contient 13 sub routine je leur fait appel par un module voila le code prend 1 heure pour analyser 16000 lignes en gros je fait une comparaison ligne par ligne de 4 colonnes et autre 4 colonnes et j'affiche les resultats dans autres colonnes voila le ficher sur le quelle je travaille compar-test.xlsm
si vous pouvez m'aider a trouver une solution et merci .
 

cedric_hiss

XLDnaute Junior
Re : Code prend 1 heure pour afficher les resultats

Bonjour tehBenoit59 ,

wow ca apparait compliqué lool , j ai esaayé le code i y a seulement un probleme avec le rank et les feautures par exemple dans le fichier que je t ai envoyé on a la communauté 6ADB a changé seulement le rank alors dans le resultaton m affiche quelle a change de features de rank et que elle est new community et quelle est deleted community en meme temps et pareil pour BHZA elle a change e rank et les features mais on m affiche que elle est deleted community et qu elle est new community !
 

thebenoit59

XLDnaute Accro
Re : Code prend 1 heure pour afficher les resultats

Sur le fichier que tu m'as envoyé les deux features ne sont pas triées dans le même ordre, or dans la fichier comprenant plus de 16000 lignes ça a l'air d'être le cas, je vérifie ligne par ligne par ligne.
 

cedric_hiss

XLDnaute Junior
Re : Code prend 1 heure pour afficher les resultats

oui exactement enfaite au lieu d afficher que il y a seulement un changement de rank le code affiche les feartures et le rank et apres quand il y a un changement de rank et de features le code affiche que la communautee et supprimer et nouvelle en meme temps est ce que c est possible de corriger ca , serieusement moi je suis null en ce qui concerne les dictionnaire et les tableau ca c est pour les maitre , est ce que vous pouve m aider svp ?
 

cedric_hiss

XLDnaute Junior
Re : Code prend 1 heure pour afficher les resultats

car pour chaque communauté ele peux etre que supprimer ou bien ajouter ou changement de rank ou de features ou rank et features en meme temps mais elle peux pas etre nouvelle et en meme temps supprimé , pour toi quand t as essayé le code il vous rend le resultat comme l exemple que j ai fournis ??
 

thebenoit59

XLDnaute Accro
Re : Code prend 1 heure pour afficher les resultats

Ce code fonctionne correctement sur ton fichier exemple.

Code:
Option Explicit
Option Base 1

Sub Comparatif_Release()
Dim t1, t2, c, temp, temp2
Dim d(1 To 6) As Object
Dim i&, j&, l&, l2&
Dim f As Worksheet

'On place les données dans deux tableaux.
Set f = Sheets("Sheet1")
With f
    l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    t1 = .Range("a3:e" & l).Value
    t2 = .Range("g3:k" & l).Value
End With

'Nous créons les dictionnaires.
For i = 1 To 6
    Set d(i) = CreateObject("Scripting.Dictionary")
Next i

'Nous réalisons un index par communauté.
For i = LBound(t1) To UBound(t1)
    d(1)(t1(i, 1) & ":" & t1(i, 2)) = d(1)(t1(i, 1) & ":" & t1(i, 2)) & i & ":"
    d(2)(t2(i, 1) & ":" & t2(i, 2)) = d(2)(t2(i, 1) & ":" & t2(i, 2)) & i & ":"
Next i

'Nous vérifions si les communautés existent dans les deux dictionnaires.
'S'il n'existe pas dans d(2), c'est une suppression
For Each c In d(1).Keys
    If Not d(2).Exists(c) Then
        d(4)(c) = d(1)(c)
    Else: d(3)(c) = ""
    End If
Next c

'S'il n'existe pas dans d(1), c'est un ajout
For Each c In d(2).Keys
    If Not d(1).Exists(c) Then
        d(5)(c) = d(2)(c)
    Else: d(3)(c) = ""
    End If
Next c

'Nous allons commencer à extraire les valeurs.
j = 3

'On extrait les communautés supprimées.
For Each c In d(4)
'Nous créons un tableau temporaire, reprenant les lignes à analyser.
    temp = Split(d(1)(c), ":")
        d(6)(t1(temp(0), 1) & ":" & t1(temp(0), 1) & ":" & "Deleted Community") = d(6)(t1(temp(0), 1) & ":" & t1(temp(0), 1) & ":" & "Deleted Community") & "Old Rank :" & t1(temp(0), 5)
        For i = LBound(temp) To UBound(temp) - 1
            Debug.Print t1(temp(i), 1)
            l = temp(i)
            d(6)(t1(l, 1) & ":" & t1(l, 1) & ":" & "Deleted Community") = d(6)(t1(l, 1) & ":" & t1(l, 1) & ":" & "Deleted Community") & Chr(10) & "Old Features :" & t1(l, 3)
        Next i
Next c

'On extrait les communautés supprimées.
For Each c In d(5)
'Nous créons un tableau temporaire, reprenant les lignes à analyser.
    temp = Split(d(2)(c), ":")
        d(6)(t2(temp(0), 1) & ":" & t2(temp(0), 1) & ":" & "New Community") = d(6)(t2(temp(0), 1) & ":" & t2(temp(0), 1) & ":" & "New Community") & "New Rank :" & t2(temp(0), 5)
        For i = LBound(temp) To UBound(temp) - 1
            Debug.Print t2(temp(i), 1)
            l = temp(i)
            d(6)(t2(l, 1) & ":" & t2(l, 1) & ":" & "New Community") = d(6)(t2(l, 1) & ":" & t2(l, 1) & ":" & "New Community") & Chr(10) & "Old Features :" & t2(l, 3)
        Next i
Next c

'On va comparer les communautés encore présentes.
'Nous allons créer deux tableaux pour reprendre les valeurs à comparer.
'1ère étape, nous enregistrons les lignes à analyser.
For Each c In d(3).Keys
    temp = Split(d(1)(c), ":")
    temp2 = Split(d(2)(c), ":")
    'Nous comparons les tableaux.
    '1. Nous comparons les Rank.
    For i = LBound(temp) To UBound(temp) - 1
        l = temp(i): l2 = temp2(i)
    Next i
Next c

'On ajoute les valeurs à la feuille.
For Each c In d(6)
    Cells(j, "O").Resize(, 3).Value = Split(c, ":")
    Cells(j, "R").Value = d(6)(c)
    j = j + 1
Next c
End Sub
 

cedric_hiss

XLDnaute Junior
Re : Code prend 1 heure pour afficher les resultats

ca est exact pour les new et deleted communities , mais ca traite pas le changement de rank ou de features !! est ce que c est impossible de les ajouter dans ce code vue qu on fait des suppressions
 

thebenoit59

XLDnaute Accro
Re : Code prend 1 heure pour afficher les resultats

Dans ton fichier exemple, les changements de rang sont traités, si je te file le bon code ça ira mieux :

Code:
Option Explicit
Option Base 1

Sub Comparatif_Release()
Dim t1, t2, c, temp, temp2
Dim d(1 To 6) As Object
Dim i&, j&, l&, l2&
Dim f As Worksheet

'On place les données dans deux tableaux.
Set f = Sheets("Sheet1")
With f
    l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    t1 = .Range("a3:e" & l).Value
    t2 = .Range("g3:k" & l).Value
End With

'Nous créons les dictionnaires.
For i = 1 To 6
    Set d(i) = CreateObject("Scripting.Dictionary")
Next i

'Nous réalisons un index par communauté.
For i = LBound(t1) To UBound(t1)
    d(1)(t1(i, 1) & ":" & t1(i, 2)) = d(1)(t1(i, 1) & ":" & t1(i, 2)) & i & ":"
    d(2)(t2(i, 1) & ":" & t2(i, 2)) = d(2)(t2(i, 1) & ":" & t2(i, 2)) & i & ":"
Next i

'Nous vérifions si les communautés existent dans les deux dictionnaires.
'S'il n'existe pas dans d(2), c'est une suppression
For Each c In d(1).Keys
    If Not d(2).Exists(c) Then
        d(4)(c) = d(1)(c)
    Else: d(3)(c) = ""
    End If
Next c

'S'il n'existe pas dans d(1), c'est un ajout
For Each c In d(2).Keys
    If Not d(1).Exists(c) Then
        d(5)(c) = d(2)(c)
    Else: d(3)(c) = ""
    End If
Next c

'Nous allons commencer à extraire les valeurs.
j = 3

'On extrait les communautés supprimées.
For Each c In d(4)
'Nous créons un tableau temporaire, reprenant les lignes à analyser.
    temp = Split(d(1)(c), ":")
        d(6)(t1(temp(0), 1) & ":" & t1(temp(0), 1) & ":" & "Deleted Community") = d(6)(t1(temp(0), 1) & ":" & t1(temp(0), 1) & ":" & "Deleted Community") & "Old Rank :" & t1(temp(0), 5)
        For i = LBound(temp) To UBound(temp) - 1
            Debug.Print t1(temp(i), 1)
            l = temp(i)
            d(6)(t1(l, 1) & ":" & t1(l, 1) & ":" & "Deleted Community") = d(6)(t1(l, 1) & ":" & t1(l, 1) & ":" & "Deleted Community") & Chr(10) & "Old Features :" & t1(l, 3)
        Next i
Next c

'On extrait les communautés supprimées.
For Each c In d(5)
'Nous créons un tableau temporaire, reprenant les lignes à analyser.
    temp = Split(d(2)(c), ":")
        d(6)(t2(temp(0), 1) & ":" & t2(temp(0), 1) & ":" & "New Community") = d(6)(t2(temp(0), 1) & ":" & t2(temp(0), 1) & ":" & "New Community") & "New Rank :" & t2(temp(0), 5)
        For i = LBound(temp) To UBound(temp) - 1
            Debug.Print t2(temp(i), 1)
            l = temp(i)
            d(6)(t2(l, 1) & ":" & t2(l, 1) & ":" & "New Community") = d(6)(t2(l, 1) & ":" & t2(l, 1) & ":" & "New Community") & Chr(10) & "Old Features :" & t2(l, 3)
        Next i
Next c

'On va comparer les communautés encore présentes.
'Nous allons créer deux tableaux pour reprendre les valeurs à comparer.
'1ère étape, nous enregistrons les lignes à analyser.
For Each c In d(3).Keys
    temp = Split(d(1)(c), ":")
    temp2 = Split(d(2)(c), ":")
    'Nous comparons les tableaux.
    For i = LBound(temp) To UBound(temp) - 1
        On Error Resume Next
        l = temp(i): l2 = temp2(i)
        If t1(l, 5) <> t2(l2, 5) Then d(6)(t1(l, 1) & ":" & t1(l, 2) & ":" & "Rank") = "Old Rank :" & t1(l, 5) & ", New Rank :" & t2(l2, 5) & " Change percentage : " & Round((t2(l2, 4) / t1(l, 4) - 1) * 100, 2) & "%"
        If t1(l, 3) <> t2(l2, 3) Then d(6)(t1(l, 3) & ":" & t1(l, 2) & ":" & "Features") = d(6)(t1(l, 3) & ":" & t1(l, 2) & ":" & "Features") & "Old Features :" & t1(l, 3) & ", New Features :" & t2(l2, 3) & Chr(10)
    Next i
Next c

'On ajoute les valeurs à la feuille.
For Each c In d(6)
    Cells(j, "N").Resize(, 3).Value = Split(c, ":")
    Cells(j, "Q").Value = d(6)(c)
    j = j + 1
Next c

End Sub
 

cedric_hiss

XLDnaute Junior
Re : Code prend 1 heure pour afficher les resultats

Rebonjour the benoit95 le code est exactement ce que je souhaitais mais j ai remarqué que pour les changement de features il affiche toutes les features est ce que c est possible de afficher que celle qui sont changés les autres qui sont pareils on les affiche pas ??
 

Discussions similaires

Statistiques des forums

Discussions
312 836
Messages
2 092 651
Membres
105 479
dernier inscrit
chaussadas.renaud