Bonjour à tous, 

Je cherche à optimiser le temps d'exécution de mon code VBA. Pour vous remettre dans le contexte, je dispose d'un tableau de 80 000 lignes et 24 colonnes. La colonne n°4 contient un n° d'identification lié à un individu. Après avoir trié mon tableau selon cette colonne, je parcours mon tableau en comparant les valeurs des cellules de la colonne 4 et dès que j'observe un doublon, je récupère les données des colonnes 18, 19, 20 et 21 pour les concaténer dans une seule ligne. 

Plus simplement, si j'ai D4 = D5 alors R4 = R4 & " ; " & R5 ; idem pour S4, T4, U4 et V4. 

Si j'ai D4=D5=D6, je récupère les données de D5 et D6 dans la ligne 4. 

Sub SupprDoublons()

Dim structMSS As Variant
Dim concatMSS As String
Dim concatDomaine As String
Dim concatDatAlim As Date
Dim concatDatMaj As Date
Dim longTab As Long
Dim Tablo() As Variant
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
Sheets("Annuaire").Select

Tablo() = Range("Annuaire")
longTab = UBound(Tablo())




i = 2

Do While i < longTab

    structMSS = Cells(i, 4)
    If structMSS = 0 Then Exit Do
    

    j = i + 1
    Do While j < longTab
    
        If structMSS = Cells(j, 4) Then
        
            concatMSS = Cells(j, 18)
            concatDomaine = Cells(j, 19)
            concatDatAlim = Cells(j, 20)
            concatDatMaj = Cells(j, 21)
                        
                        
            Cells(i, 18) = Cells(i, 18) & " ;" & Chr(10) & concatMSS
            Cells(i, 18).Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Cells(i, 19) = Cells(i, 19) & " ;" & Chr(10) & concatDomaine
            Cells(i, 19).Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Cells(i, 20) = Cells(i, 20) & " ;" & Chr(10) & concatDatAlim
            Cells(i, 20).Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Cells(i, 21) = Cells(i, 21) & " ;" & Chr(10) & concatDatMaj
            Cells(i, 21).Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            Cells(j, 4).EntireRow.Delete Shift:=xlUp
            i = i - 1
            
            
            
        End If
        j = j + longTab
        If j > longTab Then Exit Do
        
        
    Loop
    i = i + 1
    
Loop
Application.ScreenUpdating = True
End Sub

Le problème est que le temps d'exécution est d'environ 1/2h - 1h lorsque j'exécute ce code. 

J'ai entendu parler de Scripting.dictionary pour stocker les valeurs dans la mémoire vive de l'ordinateur et ainsi gagner en vitesse d'exécution. 

Pourriez-vous m'indiquer quelle est la démarche à suivre pour optimiser la vitesse d'exécution de mon code ? 

Je vous remercie par avance, 

Salut,

Il y a le Application.ScreenUpdating, c'est un bon début.

Tu fais toutes tes opérations directement sur la feuille, ce qui prend énormément de temps.

Remplace tes lectures et écritures sur feuille par des tableaux que tu colleras ensuite dans ta feuille, par exemple :

' Ce code multiplie toutes les valeurs de la plage A1:B15 par 100

dim arrayValues as Variant
arrayValues = Range("A1:B15").value

Dim i as Integer, j as Integer
For i=LBound(arrayValues,1) to UBound(arrayValues,1)
    For j=LBound(arrayValues,2) to UBound(arrayValues,2)
        arrayValues(i,j) = 100*arrayValues(i,j)
    Next
Next

Range("A1:B15").value = arrayValues

En utilisant ça tu auras un premier gain de temps siginificatif.

Ensuite on peut regarder ton algo. Il est vraiment fonctionnel ? Je dis ça à cause de :

        j = j + longTab
        If j > longTab Then Exit Do

Je pense que cette condition sera toujours vraie donc la boucle est inutile.

Aussi, ça te fera pas gagner de temps mais c'est plus par esthétique, tu fais 4 fois la même opération sur des colonnes successives, à mettre dans une boucle.

Dans ces opérations, pourquoi faire le Copy/PasteSpecial ?

J'ai une idée d'algo, pas sûr qu'il fonctionnera mais on pourra voir plus tard, en gros :

- copier ta plage dans un tableau "before" (faudra changer les noms mais j'ai pas d'idées sur le moment)

- créer un tableau "after" qui a autant de lignes que d'identifiants uniques

- parcourir le tableau "before"

    - pour chaque nouvel ID : copier toute la ligne dans le tableau "after"

    - si c'est le même ID qu'avant (toujours en considérant que tes ID sont triés) alors faire les concaténations dans le tableau "after"

- supprimer les données de ta plage

- coller le tableau "after" dans ta plage

Il y a quelques détails qu'il faudra voir (gérer l'itérateur sur le tableau "after", compter le nombre d'ID uniques, etc...).

Salut, 

Merci pour ce retour rapide :) 

Je vais me pencher sur toutes ces infos et je reviens avec le nouveau temps d'exécution dès que possible.

Concernant 

j = j + longTab
If j > longTab Then Exit Do

C'était pour sortir immédiatement du "Do While" et passer directement à l'incrémentation de "i" (et ensuite j reprends la valeur de i+1). Mais finalement je me rends compte que ce n'était pas utile vu qu'après on teste "Do While j< longTab".

A+

Théo

Hello, 

J'ai un problème si ma liste se termine par un doublon/triplet etc.. 

Voici le code test rédigé : 

Sub SupprDoublons()


Dim longTab As Long
Dim i As Long
Dim j As Long
Dim tabloInit As Variant
Dim tabloFin As Variant


Sheets("Annuaire").Select


tabloInit = Range("annuaire").Value
longTab = UBound(tabloInit)
tabloFin = Range("G3:H20").Value

n = 1
i = 1

For i = 1 To longTab - 1


    k = 0
    j = i + 1
    If tabloInit(i, 1) = tabloInit(j, 1) Then
        tabloFin(n, 2) = tabloInit(i, 2)
        Do While tabloInit(i, 1) = tabloInit(j, 1)
        
        tabloFin(n, 1) = tabloInit(i, 1)
        tabloFin(n, 2) = tabloFin(n, 2) & " ;" & Chr(10) & tabloInit(j, 2)
        
        j = j + 1
        k = k + 1
        Loop
        n = n + 1
        i = i + k
    End If

Next i

Range("G3:H20").Value = tabloFin

End Sub

Pour tester ce code j'ai un tableau annuaire présent dans la plage B3:C18 (avec colonne 1 : ID et colonne 2 : une lettre). Les doublons peuvent être présent au niveau de l'ID. 

Si j'ai bien compris, le problème de subscript out of range lorsque ma liste se termine par un doublon est qu'on appelle une des lignes de mon tableau dont la valeur de i est supérieur à la taille de mon tableau. 

Néanmoins je ne trouve pas de parade pour gérer ce cas.. 

Merci d'avance pour vos retours, 

Théo

Il vaut mieux ne jamais toucher à la variable d'une boucle For (le i=i+k), c'est un coup à s'embrouiller, louper des valeurs ou sortir de la plage de valeurs possibles.

Sinon je pense que tu te compliques la vie avec j et k.

En supposant que tes lignes sont triées par ID comme tu l'avais dit dans ton premier post, tu parcours tabloInit (au passage, la borne haute de la boucle sur i n'est pas bonne, tu vires la dernière valeur). Tu crées un compteur pour savoir où tu en es dans le remplissage de tabloFin (le n de ton code actuel il me semble).

Ensuite pour chaque ligne de tabloInit, tu compares l'ID à celui de la ligne en cours de tabloFin (tabloFin(n,1)), si c'est le même ID alors tu fais la concaténation sinon tu incrémentes n de 1 et remplis la nouvelle ligne de tabloFin.

Je peux t'écrire quelque chose qui ressemble un peu plus à du pseudo-code si tu veux.

30 min --> 1s

J'ai un seul "problème", j'ai la première ligne de mon tabloFin qui est vide vu qu'au premier If on ne respecte pas l'égalité et donc on entre dans le else qui fait incrémenter la valeur de n. 

Voici le code : 

Sub SupprDoublons()


Dim longTab As Long
Dim i As Long
Dim j As Long
Dim tabloInit As Variant
Dim tabloFin As Variant


Sheets("Annuaire").Select


tabloInit = Range("Table1").Value
longTab = UBound(tabloInit)
tabloFin = Sheets("Sheet2").Range("A2:X200000").Value

n = 1
For i = 1 To longTab

    If tabloInit(i, 4) = tabloFin(n, 4) Then
        
        For j = 18 To 21
        
        tabloFin(n, j) = tabloFin(n, j) & " ;" & Chr(10) & tabloInit(i, j)
        
        Next j
        
    Else
    
        
        n = n + 1
        
        For k = 1 To 24
        
        tabloFin(n, k) = tabloInit(i, k)
        tabloFin(n, k) = tabloInit(i, k)
        
        Next k
        
    End If

Next i

Sheets("Sheet2").Range("A2:X200000").Value = tabloFin

End Sub

[EDIT]

Merci pour cette aide rapide ! 

-
Edité par ThéVBA 26 juillet 2018 à 15:29:51