Discussion :

[Deuffr]

Hello,

Je suis a la recherche d'un choc de simplification pour un debutant en VBA. J'ai une macro qui fonctionne mais qui me semble tres lourde et prends beaucoup de temps et d'energie a s'executer. Je pense que cela est principalement lie a la redaction dela macro plutot qu'au volume des donnees traitees (30000 cells). Elle inclut notamment un double For Each que j'essaye de simplifier sans succes. Auriez vous des idees ?

La macro va chercher des valeurs dans une feuille et en copie une partie en fonction de leur valeur dans une autre sous forme de liste basique (regroupement de la meme info sur une meme colonne) et elimine ensuite les doublons de cette colonne.


La voici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Sub Single_Number_Calculation()
 
MsgBox "Wait Until the Process is Completed"
 
 
'nettoyage des versions precedentes' 
Columns("A:A").ClearContents
 
Application.ScreenUpdating = False
 
Dim plageCTN As Range, plageLDL As Range, Cel As Range, Celbis As Range
Dim Unique As Object, rawCel As Range
 
With Worksheets("Database")
 
valcherch = "NO"
derlig = .Range("B" & Rows.Count).End(xlUp).Row
 
  Set plageCTN = .Range("AQ2:AQ" & derlig)
  Set plageLDL = .Range("AR2:AR" & derlig)
derlig = 1
    End With
 
 
  With Worksheets("Single Number Calculation")
 
    For Each Cel In plageCTN
 
   If Cel.Value <> valcherch Then
 
 
    Cells(derlig, 1) = Cel.Value
 
    derlig = derlig + 1
 
        End If
 
Next Cel
 
 For Each Celbis In plageLDL
 
   If Celbis.Value <> valcherch And Celbis.Value <> 0 Then
 
 
    Cells(derlig, 1) = Celbis.Value
 
    derlig = derlig + 1
 
        End If
 
Next Celbis
 
 
End With
 
Set Unique = CreateObject("Scripting.Dictionary")
 
    For Each rawCel In Range("a2:a" & derlig)
        If Not Unique.Exists(rawCel.Value) Then Unique.Add rawCel.Value, rawCel.Value
    Next rawCel
    Range("a2:a" & derlig).EntireRow.Delete
    Range("a2:a" & Unique.Count + 1) = Application.Transpose(Unique.items)
 
 
Application.ScreenUpdating = True
 
MsgBox "Process Completed"
 
End Sub

Merci d'avance pour votre aide

[Marc-L]

Bonjour, bonjour !

En jetant un œil au code, cela doit être la partie précédant le dictionnaire devant forcément ralentir l'exécution …
Est-elle nécessaire, pourquoi ne pas utiliser directement le dictionnaire ? C'est la logique qu'il faut simplifier !
Plus il y a de boucles et plus cela pourrait durer …


______________________________________________________________________________________________________
Je suis Paris, Charlie, …

[Deuffr]

Exactement,

La partie tri des doublons fonctionne (malgre tout, j'ai trouve comment le simplifier avec tes liens).

C'est ma double For Each qui ralentit le traitement mais j'avoue ne pas avoir trouve de piste simple (et que j'aurais comprise) ni sur le forum ni sur le net pour aborder le probleme avec une autre logique.

Je ne suis pas sur de comprendre ta question vis a vis du dictionnaire. L'idee est que je pars d'une base dans laquelle des numeros de telephones sont dans deux colonnes differentes, je cherche a recuperer l'ensemble des cellules qui contiennent les numeros de ces colonnes (certaines cases sont vides ou N/A d'ou les IF) , mettre tout a un seul endroit, eliminerles doublons et compter le nombre de numeros

Je vais regarder comment tu envisages d'utiliser le dictionnaire pour le faire

[Marc-L]

J'ai du mal à visualiser l'organisation de tes données : joindre un classeur exemple en .xlsx (sans code donc)

avec une feuille contenant les données sources et une autre feuille affichant le résultat désiré …

[Deuffr]

J'ai resolu mon probleme, ca prend un quart de seconde maintenant. L'idee du dictionnaire etait excellente. Entre tes liens et la piste, tu m'as surtout permis de comprendre la logique derriere le dictionnaire (en fait j'evite le copier-coller/delete tres lourd, je creer le dictionnaire ou je stock et que j'affiche ensuite, c'est TOP)

MERCI !

Mon code successful ci-dessous. Il me semble assez simple en plus.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 Sub Single_Number_Calculation()
 
MsgBox "Wait Until the Process is Completed"
 
Columns("A:A").ClearContents
 
Application.ScreenUpdating = False
 
Dim plageCTN As Range, plageLDL As Range, Cel As Range
Dim Unique As Object, rawCel As Range
With Worksheets("Database")      
derlig = .Range("B" & Rows.Count).End(xlUp).Row       
  Set plageCTN = .Range("AQ2:AQ" & derlig)
  Set plageLDL = .Range("AR2:AR" & derlig)
 
 
Set Unique = CreateObject("Scripting.Dictionary")   
    For Each rawCel In plageCTN
        If Not Unique.Exists(rawCel.Value) Then Unique.Add rawCel.Value, rawCel.Value
    Next rawCel
 
   For Each Cel In plageLDL
        If Not Unique.Exists(Cel.Value) Then Unique.Add Cel.Value, Cel.Value
    Next Cel 
Unique.Remove ("NO")
Worksheets("Single Number Calculation").Range("a2:a" & Unique.Count + 1) = Application.Transpose(Unique.items)
End With
Application.ScreenUpdating = True
 
MsgBox "Process Completed"
 
End Sub

[casefayere]

Bonjour,
autre methode, si j'ai compris, bien sur ce code doit être adapté à tes plages

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Listeunique()
Dim mondico, a, b, i As Long, dercel As Range
  Set mondico = CreateObject("Scripting.Dictionary")
  Set dercel = Range("A" & Rows.Count).End(xlUp)
  a = Range("A2", dercel)
  Set dercel = Range("B" & Rows.Count).End(xlUp)
  b = Range("B2", dercel)
  For i = LBound(a) To UBound(a)
    mondico(a(i, 1)) = ""
  Next i
  For i = LBound(b) To UBound(b)
    mondico(b(i, 1)) = ""
  Next i
 
  [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Edit : étourdi, j'ai corrigé la deuxième valeur de "dercel"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Set dercel = Range("B" & Rows.Count).End(xlUp)

[Deuffr]

J'aimerais aller plus loin.

En plus d'identifier les doublons, j'aimerais que pour chaque doublon, on supprimme celui qui m'interesse le moins selon une relation conditionnelle.

Je m'explique :

Dans le champ A, j'ai deux doublons TOTO;
Dans le champ B, j'ai deux date "recente" et "vieille"
Dans le champ C, j'ai une cellule remplie, une cellule "vide"

Pour chaque doublon de TOTO (qui est sur la colonne Q d'un fichier allant de A a DO), j'aimerais que le doublon qui soit supprime soit celui dont la date est vieille en B et la cellule vide en C. On supprimerait la ligne entiere du doublon.

J'ai essaye avec une collection cette apres-midi sans succes mais je ne pense pas que cela m'aide car elle ne prend pas en compte la premiere apparition de la valeur doublon.

Je seche un peu sur comment aborder le probleme. Auriez vous des pistes ?

=> Je n'ai pas reussi a trouver/comprendre d'autre sujet pouvant m'eclairer

[Marc-L]

Collection, dictionnaire : du pareil au même : cela fonctionne bien si la Logique est respectée …

Exemples dans les deux premières pages de ce forum :

VBA_Suppression & addition_Doublons

Aide pour optimisation code doublons spécifique svp …

[Deuffr]

tu as poste le code ci-dessous dans l'un des posts. Je pense qu'il peut m'aider a la resolution de mon probleme mais... je ne le comprends pas.

Pourrais-tu mexpliquer etape par etape la logique ? Je ne comprends pas le demarrage avec Ubound notamment.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub DemoC()
        Dim cLig As New Collection, C As Byte, L&, R&, VA, VR
    With Feuil1
        VA = .Cells(1).CurrentRegion.Value
        If UBound(VA, 2) < 5 Then Beep: Exit Sub
        ReDim VR(1 To UBound(VA) - 1, 1 To 5)
    For R = 2 To UBound(VA)
           On Error Resume Next
           L = cLig(VA(R, 2))
           On Error GoTo 0
        If L Then
            VR(L, 4) = VR(L, 4) + VA(R, 4)
            VR(L, 5) = VR(L, 5) + VA(R, 5)
        Else
            L = cLig.Count + 1
            cLig.Add L, VA(R, 2)
            For C = 1 To 5:  VR(L, C) = VA(R, C):  Next
        End If
                L = 0
    Next
        If cLig.Count < UBound(VR) Then
            .[A2:E2].Resize(cLig.Count).Value = VR
            .Rows(cLig.Count + 2 & ":" & UBound(VA)).Delete
        End If
    End With
        Set cLig = Nothing
End Sub

[RyuAutodidacte]

Bonjour,
je me suis servi de ce code comme exercice et compréhension des tableaux/collections
je te fourni les explications que j'en ai déduit (avec petites corrections de Marc-L )
PS : j'ai laissé les debug.print qui permet de voir le cheminement du code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub DemoC()
Dim cLig As New Collection, C As Byte, L&, R&, VA, VR
    With Feuil1 'Sur la Feul1
        VA = .Cells(1).CurrentRegion.Value ' VA (Variant) = plage pour l'ensemble des valeurs
        If UBound(VA, 2) < 5 Then Beep: Exit Sub 'Si le nombre de colonne inferieur à 5 alors joue le son beep (propre au sytème) et quitte la macro
        ReDim VR(1 To UBound(VA) - 1, 1 To 5) 'Création du tableau VR : on Redimensionne le nombre de lignes (-1 : entête) et de colonnes de 1 à 5
        Debug.Print UBound(VR) & " : " & UBound(VR, 2)
    For R = 2 To UBound(VA) 'Boucle For de R (type long) = 2 à hauteur max du tableau VA
                    Debug.Print R & " / " & UBound(VA) & "Valeur la plus haute du tableau"
           On Error Resume Next 'En cas erreur passe à la ligne suivante
           L = cLig(VA(R, 2)) 'A chaque erreur L = 0, sinon L est égal à la valeur enregistrée dans la collection
           Debug.Print L & " / " & VA(R, 2)
           On Error GoTo 0 'on désactive le gestionnaire d'erreur activé dans la procédure en cours (on récupère la valeur de L)
        If L Then 'équivalent de If L<>0 Then
        Debug.Print VR(L, 4) & " + " & VA(R, 4) & " = "; VR(L, 4) + VA(R, 4)
            VR(L, 4) = VR(L, 4) + VA(R, 4) 'on additionne en 4è col  VR + VA pour résultat en VR correspondant à la ligne L et R
        Debug.Print VR(L, 5) & " + " & VA(R, 5) & " = "; VR(L, 5) + VA(R, 5)
            VR(L, 5) = VR(L, 5) + VA(R, 5) 'on additionne en 5è col  VR + VA pour résultat en VR correspondant à la ligne L et R
        Else
            L = cLig.Count + 1 'Permet d'incrémenter le n° de ligne pour VR
            cLig.Add L, VA(R, 2) 'enregistrement dans la collection du n° de ligne dans VR de la clef VA(R,2) … (index)
            Debug.Print L & " / " & cLig(VA(R, 2))
            For C = 1 To 5:  VR(L, C) = VA(R, C): Debug.Print VA(R, C):  Next ' on enregistre dans le tableau VR les donnée en ligne de la REF
        End If
                L = 0 ' on initialise L à 0
    Next
        If cLig.Count < UBound(VR) Then 'Si le nomdre de ligne de la collection est strictement inferieur au nombre de ligne max du tableau VR alors
        Debug.Print cLig.Count & " < " & UBound(VR)
            .[A2:E2].Resize(cLig.Count).Value = VR 'les valeurs de la plage VR sont copiés dans feuil1 de plage équivalente
            Debug.Print .[A2:E2].Resize(cLig.Count).Address
            .Rows(cLig.Count + 2 & ":" & UBound(VA)).Delete 'on efface les lignes de x1 à x2 (cLig.Count + 2 à UBound(VA)
            ' + 2 => +1 pour l'entête et + 1 pour être sur la ligne superieur à la plage venant d'être copiée
            Debug.Print cLig.Count + 2 & " : " & UBound(VA)
        End If
    End With
        Set cLig = Nothing
End Sub

[Marc-L]

Je ne comprends pas le demarrage avec Ubound notamment.

Là c'est pourtant simple et à portée de clic : placer le curseur texte dans le code sur UBound puis appuyer sur la touche !

Dans DemoC la collection sert juste d'index des références pour la variable tableau VR … Et merci Ryu pour ton intervention !