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