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

oui bien sur , j'ai deux release a comparer les meme type de donnees le coresitecode et le site code referent a une communautees les features referent a des fonctionnalitees utilisees par ces communautees total_PNRs ce sont les reservations de chaque communautes et le rank id c est le classement je compare les deux release pour savoir les changement suivants j'affiche le coresite code et le sitecode a coté le changement et apres les details de ce changement .

les changement que je traite sont les suivant :

un changement de rank ==> details : le nouveau et l ancien rank et le poucentage de changement
un changement de features ==> details : nouvelle features , et features supprimes
une nouvelle communaute ==> detail : nouvelle features et son rank
une communautes supprime ==> details : ancien features et ancien rank .
 

cedric_hiss

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

et j ai oublier quand j ai un changement de rank et feature en meme temps

==> detail: un changement de rank ==> details : le nouveau et l ancien rank et le poucentage de changement
:un changement de features ==> details : nouvelle features , et features supprimes
 

gosselien

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

Bonjour,

de fait ton code ici (à part les sub deleteR2dups et deleteR1dups) est très lent; je pense que l'idée du dico est la meilleure , associée à un tableau mais je n'ai toujours pas assez de connaissance pour ce faire; je vais suivre cet intéressant fil d'autant que je vois qu'un compatriote est déjà sur la balle :)

P.
 

thebenoit59

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

Bonjour Cedric.
Un premier essaie :

Code:
Option Explicit

Sub Comparatif_Release()
Dim t1, t2, c
Dim d As Object
Dim i&, j&, l&
Dim f As Worksheet

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

Set d = CreateObject("Scripting.Dictionary")
For i = LBound(t1) To UBound(t1)
    If t1(i, 1) & t1(i, 2) <> t2(i, 1) & t2(i, 2) Then
        d(t1(i, 1) & ":" & t1(i, 2) & ":" & "Deleted community") = d(t1(i, 1) & ":" & t1(i, 2) & ":" & "Deleted community") & "Old Features :" & t1(i, 3) & Chr(10)
        d(t2(i, 1) & ":" & t2(i, 2) & ":" & "New community") = d(t2(i, 1) & ":" & t2(i, 2) & ":" & "New community") & "New Features :" & t2(i, 3) & Chr(10)
    Else:
        If t1(i, 3) <> t2(i, 3) Then
            d(t1(i, 1) & ":" & t1(i, 2) & ":" & "Features") = d(t1(i, 1) & ":" & t1(i, 2) & ":" & "Features") & "New Features: " & t2(i, 3) & ", Old Features: " & t1(i, 3) & Chr(10)
        End If
        If t1(i, 5) <> t2(i, 5) Then
            d(t1(i, 1) & ":" & t1(i, 2) & ":" & "Rank") = "New Rank: " & t2(i, 5) & ", Old Rank: " & t1(i, 5) & ", Change percentage: " & Round((t2(i, 4) / t1(i, 4) - 1) * 100, 2) & "%"
        End If
    End If
Next i

With f
    i = 3
    For Each c In d.Keys
        .Cells(i, "N").Resize(, 3).Value = Split(c, ":")
        .Cells(i, "Q").Value = d(c)
        i = i + 1
    Next c
End With

End Sub
 

Discussions similaires

Statistiques des forums

Discussions
312 836
Messages
2 092 630
Membres
105 475
dernier inscrit
ramzi slama