Optimisation de code

Version imprimable

Bonjour à tous et merci de me lire!
Voilà, j'ai pondu un code en vba qui fait plein de chose mais mon problème c'est qu'il est un peu trop lent.
Je vous explique:
Mon code doit traiter plus de 2000 fichiers à la suite (il retire des lignes, reclasses les colonnes,...). J'ai essayé d'optimiser moi-même mais je me demande si on ne pourrais pas mieux faire.
Ce que je vous demande, c'est votre avis!
Voici le code:

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
Public Sub Suppression_doublons()
 
    'Les déclarations des variables
    Dim sNumTel As String, sNom As String, sAdd As String, iCP As String
    Dim iNb_Lignes As Integer
    Dim rCible As Range, iLigne As Integer, rRgeA As Range, rRgeB As Range
 
    'initialisation des variables
    iPos1 = 0
    iPos2 = 0
    iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
 
        'Boucle sur toutes les lignes du fichier
        For i = 1 To iNb_Lignes Step 1
 
 
            'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
            '#####################################
            If Left(Range("E" & i).Value, 2) = "06" Then
                If Range("G" & i).Value = "" Then
                    Range("E" & i).Cut
                    Range("G" & i).Select
                    ActiveSheet.Paste
                Else
                    Range("E" & i).Select
                    Selection.ClearContents
                End If
            End If
 
            'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
            '#####################################
            'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
            sChaine = Range("B" & i).Value
            iPos1 = InStr(sChaine, "-")
            If iPos1 <> 0 Then
                iPos2 = InStr(iPos1 + 1, sChaine, "-")
                If iPos2 <> 0 Then
                    iPos1 = iPos2
                End If
                sChaine = Right(sChaine, Len(sChaine) - 1 - iPos1)
                Range("B" & i).Value = sChaine
            End If
 
            'Suppression des doublons
            '#####################################
 
            sNumTel = Range("E" & i).Value
            sNom = Range("A" & i).Value
            iCP = Range("C" & i).Value
            sAdd = Range("B" & i).Value
 
 
            If sNumTel <> "" Then
 
 
               Set rCible = Range("E" & i + 1 & ":E" & iNb_Lignes).Find(what:=sNumTel, lookat:=xlWhole)
               If Not rCible Is Nothing Then
                   iLigne = rCible.Row
 
                   'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
                   If Range("A" & iLigne) = sNom Then
                      If Range("B" & iLigne) = sAdd Then
                        If Range("C" & iLigne) = iCP Then
                            rRgeA = Range("A" & i & ":K" & i)
                            rRgeB = Range("A" & iLigne & ":K" & iLigne)
 
                            'La fonction "Compter_champs_non_vides compte le nombre de colonne non vide dans le range mit en paramètre.
                            'La ligne contenant le plus de colonne vide est supprimée
                            If Compter_champs_non_vide(rRgeA) > Compter_champs_non_vide(rRgeB) Then
                                Range("A" & iLigne).EntireRow.Delete
                                i = i - 1
                                iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
                            ElseIf i <> iLigne Then
                                Range("A" & i).EntireRow.Delete
                                i = i - 1
                                iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
                            End If
                        End If
                    End If
                   End If
               End If
            End If
 
    Next i
 
End Sub
 
Function Compter_champs_non_vide(rCible As Range) As Integer
    Dim Cellules As Range
    Compter_champs_non_vide = 0
    For Each Cellules In rCible
        If Cellules.Text <> "" Then
            Compter_champs_non_vide = Compter_champs_non_vide + 1
        End If
    Next
End Function

Je vous rappelle que je ne suis pas sur que ma façon de voir les choses est la plus optimale, c'est pourquoi je suis là !!!!

déjà une première remarque, évite les select, par exemple au lieu
Code:

1 2 3 Range("E" & i).Cut Range("G" & i).Select ActiveSheet.Paste
Code:

1 2 3 Range("E" & i).Cut Range("G" & i) Else Range("E" & i).ClearContents
regarde du côté de InStrRev

Code:

iPos1 = InStrRev(sChaine, "-")

sans boucle
Code:

1 2 3 sChaine = Range("B" & i).Value ipos1 = InStrRev(sChaine, "-") Range("B" & i).Value = Mid(sChaine, ipos1 + 1)

08/11/2009, 10h20
Yolak

Merci pour cette première réponse,
effectivement c'est plus logique. JE ne savais même pas qu'on pouvais mettre des arguments à .Cut :traine:

Petite précision:
J'ai mis:

Code:

Application.ScreenUpdating = false

Dans un autre bout de code :p

Sans boucle, ça existe

Code:

1
2
3
Function Compter_champs_non_vide(rCible As Range) As Double
    Compter_champs_non_vide = Application.WorksheetFunction.CountBlank(rCible)
End Function

08/11/2009, 10h30
Yolak

Citation:

Envoyé par mercatog

déjà une première remarque, évite les select, par exemple au lieu [code]
regarde du côté de InStrRev

Code:

iPos1 = InStrRev(sChaine, "-")

sans boucle

Ok ca c'est fait, merci !
08/11/2009, 10h54
mercatog

au cas de suppression de lignes
commencer la boucle de la fin et remonter

Code:

For i= iNb_Lignes to 1 Step -1

sinon, toutes les lignes ne seront pas traitées

et revoir le i=i-1!
08/11/2009, 11h02
Yolak
Citation:
Envoyé par mercatog

Sans boucle, ça existe

Code:

1 2 3 Function Compter_champs_non_vide(rCible As Range) As Double Compter_champs_non_vide = Application.WorksheetFunction.CountBlank(rCible) End Function
Dans ce cas, est-ce que ma fonction est encore utile? Ne serais-ce pas plus rapide d'utiliser ce CountBlank directement dans mon code?

Citation:

Envoyé par mercatog

au cas de suppression de lignes
commencer la boucle de la fin et remonter

Code:

For i= iNb_Lignes to 1 Step -1

sinon, toutes les lignes ne seront pas traitées

et revoir le i=i-1!

Vraiment pas bête! Ca me permet de supprimer ce fichu i=i-1 et le recomptage des des lignes (iNb_Lignes)
08/11/2009, 11h24
mercatog

oui tu peux utiliser directement dans ton code

Code:

Application.WorksheetFunction.CountBlank(rCible)

Merci a mercatog pour ses précieux conseils!!!!!!

J'ai fait des tests, j'ai gagné presque 1/3 de temps d'exécution !
Voilà à quoi ressemble mon code maintenant:

Code:

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
Public Sub Suppression_doublons()
 
    'Les déclarations des variables
    Dim sNumTel As String, sNom As String, sAdd As String, iCP As String
    Dim iNb_Lignes As Integer, iPos1 As Integer, iNombreCell_1 As Integer, iNombreCell_2 As Integer
    Dim rCible As Range, iLigne As Integer, rRgeA As Range, rRgeB As Range
 
    'initialisation des variables
    iPos1 = 0
 
    iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
 
    'Boucle sur toutes les lignes du fichier
    For i = iNb_Lignes To 1 Step -1
 
 
        'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
        '#####################################
        If Left(Range("E" & i).Value, 2) = "06" Then
            If Range("G" & i).Value = "" Then
            Range("E" & i).Cut Range("G" & i)
            Else
            Range("E" & i).ClearContents
            End If
        End If
 
        'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
        '#####################################
        'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
        sChaine = Range("B" & i).Value
        iPos1 = InStrRev(sChaine, "-")
        If iPos1 <> 0 Then
            Range("B" & i).Value = Mid(sChaine, iPos1 + 1)
        End If
 
 
        'Suppression des doublons
        '#####################################
 
        sNumTel = Range("E" & i).Value
        sNom = Range("A" & i).Value
        iCP = Range("C" & i).Value
        sAdd = Range("B" & i).Value
 
        If sNumTel <> "" Then
            Set rCible = Range("E1:E" & i).Find(what:=sNumTel, lookat:=xlWhole)
            If Not rCible Is Nothing Then
            iLigne = rCible.Row
            'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
                If Range("A" & iLigne) = sNom And ange("B" & iLigne) = sAdd And Range("C" & iLigne) = iCP Then
                    Set rRgeA = Range("A" & i & ":K" & i)
                    Set rRgeB = Range("A" & iLigne & ":K" & iLigne)
                    iNombreCell_1 = Application.WorksheetFunction.CountBlank(rRgeA)
                    iNombreCell_2 = Application.WorksheetFunction.CountBlank(rRgeB)
 
                    'La ligne contenant le plus de colonne vide est supprimée
                    If iNombreCell_1 > iNombreCell_2 Then
                        Range("A" & iLigne).EntireRow.Delete
                    ElseIf i <> iLigne Then
                        Range("A" & i).EntireRow.Delete
                    End If
                End If
            End If
        End If
    Next i
End Sub

Si vous avez des suggestions, n'hésitez pas, je suis preneur!

au lieux de

Code:

1
2
3
4
5
                    If iNombreCell_1 > iNombreCell_2 Then
                        Range("A" & iLigne).EntireRow.Delete
                    ElseIf i <> iLigne Then
                        Range("A" & i).EntireRow.Delete
                    End If

mieux

Code:

1
2
3
         If iNombreCell_1 > iNombreCell_2 or i <> iLigne Then
                        Range("A" & iLigne).EntireRow.Delete
                    End If

on supprime le doublon, mieux supprimer iLigne au lieu de la ligne i car la ligne i a déjà passé par la boule
ça t'évite une boucle en plus

Code:

1
2
3
4
5
        sChaine = Range("B" & i).Value
        iPos1 = InStrRev(sChaine, "-")
        If iPos1 <> 0 Then
            Range("B" & i).Value = Mid(sChaine, iPos1 + 1)
        End If

Le if est il nécessaire?

08/11/2009, 13h24
Yolak
Citation:
Envoyé par mercatog

au lieux de

Code:

1 2 3 4 5 If sChaine = Range("B" & i).Value iPos1 = InStrRev(sChaine, "-") If iPos1 <> 0 Then Range("B" & i).Value = Mid(sChaine, iPos1 + 1) End If

Le if est il nécessaire?
Oui il l'est car il n'y a pas de tiret dans toutes les cellules de B.
On exécute le traitement uniquement si il y a un ou plusieurs tirets.
Est-ce une erreur de raisonnement?
08/11/2009, 13h29
mercatog

non non, c'est parfait
c'était juste une précision
ça fonctionnerait sans le if et même en l'absence de tiret (je crois)

Un petit up pour continuer sur cette lancée:

En fait mon code est un peu plus compliqué que ça.
Le SUB que j'ai mis doit en fait s'executer sur 2000 fichiers plus ou moins gros.
J'ai fait le test avec 300 fichiers, j'ai mis plus de 3h pour le traitement complet...

Je pense qu'il faut vraiment que je cherche une solution beaucoup plus rapide...

Je vous met le code complet...

Voici le "Main" qui ouvre les fichiers un a un, les traites et les enregistre en csv

Code:

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
Sub Main()
    Const Rep = "C:\Documents and Settings\*****\Bureau\*****\" ' le répertoire contenant les fichiers..
    Dim TheFile As String 'Variable pour le nom du fichier
    Dim LaDateData As Date, NewFile As String
    Dim DateDeb As Date, DateFin As Date, TempsTot As Date
 
    'Chrono
    DateDeb = Time
 
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
 
    TheFile = Dir(Rep & "*.xlsx")   'Listing des fichier Excel...
    While TheFile <> "" 'Tant que non vide
       Workbooks.Open (Rep & TheFile) 'Ouverture du fichier
 
            Call Epuration_fichiers_Main
 
            'Epuration du nom du fichier (en enlève l'extention *.xlsx
            NewFile = Left(TheFile, InStrRev(TheFile, ".") - 1)
 
            ChDir "C:\Documents and Settings\*****\Bureau\*****"
            ActiveWorkbook.SaveAs Filename:= _
                "C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV _
                , CreateBackup:=False
 
       ActiveWindow.Close
       TheFile = Dir 'Fichier suivant
    Wend
    Application.ScreenUpdating = True
 
    'Fin du chrono
    DateFin = Time
    TempsTot = DateFin - DateDeb
 
    MsgBox ("Traitement terminé" & vbCrLf & TempsTot)
 
End Sub

Ca c'est le code général qui gère les autres sub de mon traitement
(peut-etre superflu mais bon...)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private Sub Epuration_fichiers_Main()
 
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("I:I").Select
    Selection.Delete Shift:=xlToLeft
    Range("J:J").Select
    Selection.Delete Shift:=xlToLeft
 
 
    'Format "téléphone pour les case E,F,G
    Application.ErrorCheckingOptions.BackgroundChecking = False    'Suppression des balises actives
    Range("E:G").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
 
    'Suppression des lignes où il manque le CP ou la ville ou les deux
    Call Suppression_Lignes_inexploitables("C:C")
    Call Suppression_Lignes_inexploitables("D:D")
 
    'Suppression des doublons
    Call Suppression_doublons
    'MsgBox (Suppression_doublons & "Doublons supprimés")
 
End Sub

Et enfin, le code que nous avons optimisé avec un bout en plus

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Private Sub Suppression_doublons()
 
    'Les déclarations des variables
    Dim sNumTel As String, sNom As String, sAdd As String, iCP As String, schaine As String
    Dim iNb_Lignes As Long, iPos1 As Long, iNombreCell_1 As Long, iNombreCell_2 As Long
    Dim rCible As Range, iLigne As Long, rRgeA As Range, rRgeB As Range, i As Long
 
 
    'initialisation des variables
    iPos1 = 0
 
    iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
 
    'Boucle sur toutes les lignes du fichier
    For i = iNb_Lignes To 1 Step -1
 
        'Transformation des minuscules en majuscules dans les colonnes A,B,D,I
        Call Majuscule("A", i)
        Call Majuscule("B", i)
        Call Majuscule("D", i)
        Call Majuscule("I", i)
 
        'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
        '#####################################
        If Left(Range("E" & i).Value, 2) = "06" Then
            If Range("G" & i).Value = "" Then
                Range("E" & i).Cut Range("G" & i)
            Else
                Range("E" & i).ClearContents
            End If
        End If
 
        'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
        '#####################################
        'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
        schaine = Range("B" & i).Value
        iPos1 = InStrRev(schaine, "-")
        If iPos1 <> 0 Then
            Range("B" & i).Value = Mid(schaine, iPos1 + 1)
        End If
 
 
        'Mise en majuscule des champs
        schaine = Range("A" & i).Value
        Range("A" & i).Value = UCase(schaine)
        schaine = Range("A" & i).Value
        Range("A" & i).Value = UCase(schaine)
 
 
        'Suppression des doublons
        '#####################################
 
        sNumTel = Range("E" & i).Value
        sNom = Range("A" & i).Value
        iCP = Range("C" & i).Value
        sAdd = Range("B" & i).Value
 
        If sNumTel <> "" Then
            Set rCible = Range("E1:E" & i).Find(what:=sNumTel, lookat:=xlWhole)
            If Not rCible Is Nothing Then
            iLigne = rCible.Row
            'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
                If Range("A" & iLigne).Value = sNom And Range("B" & iLigne).Value = sAdd And Range("C" & iLigne).Value = iCP Then
                    Set rRgeA = Range("A" & i & ":K" & i)
                    Set rRgeB = Range("A" & iLigne & ":K" & iLigne)
                    iNombreCell_1 = Application.WorksheetFunction.CountBlank(rRgeA)
                    iNombreCell_2 = Application.WorksheetFunction.CountBlank(rRgeB)
 
                    'La ligne contenant le plus de colonne vide est supprimée
                    If iNombreCell_1 > iNombreCell_2 Or i <> iLigne Then
                        Range("A" & iLigne).EntireRow.Delete
                    End If
                End If
            End If
        End If
    Next i
End Sub
 
Private Sub Suppression_Lignes_inexploitables(rRge As String)
    Dim rCible As Range, iNb_Lignes As Long
    Do
        Set rCible = Range(rRge).Find(what:="", lookat:=xlWhole)
        If Not rCible Is Nothing Then
            Range(rCible.Address).EntireRow.Select
            Selection.Delete
            iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
        End If
    Loop While Not rCible Is Nothing And ActiveCell.Row < iNb_Lignes
End Sub
Private Sub Majuscule(sNumColonne As String, ByVal NumLigne As Long)
    Dim schaine As String
    schaine = Range(sNumColonne & NumLigne).Value
    Range(sNumColonne & NumLigne).Value = UCase(schaine)
End Sub

Voilà pour le code.

Je pensais trouver une solution dans le multithreading pour traiter les fichiers deux par deux mais j'ai pas trouvé beaucoup d'aide là dessus.

C'est peut-être mon raisonnement général qu'il faut revoir...

Un peu d'aide me ferait du bien!
Merci à vous :mouarf:

J'ai oublié une petite précision,
A la fin du traitement, je dois fusionner tous les fichiers...
Je pourrais les fusionner avant mais je suis bridé par les capacités d'excel...

Salut,

Pourquoi personne ne lui a conseillé de supprimer les Select
Exemple :
Code:

1 2 3 4 5 6 If Not rCible Is Nothing Then Range(rCible.Address).EntireRow.Select Selection.Delete iNb_Lignes = ActiveSheet.UsedRange.Rows.Count End If
Code:

1 2 3 4 5 If Not rCible Is Nothing Then Range(rCible.Address).EntireRow.Delete iNb_Lignes = ActiveSheet.UsedRange.Rows.Count End If
Ca a son importance quand on doit traiter 2000 fichiers (en 3heures !!!! énorme :lol: bonne chance)

Citation:

Envoyé par Yolak

A la fin du traitement, je dois fusionner tous les fichiers...

Tu veux dire les fichiers csv ?

15/11/2009, 00h13
Yolak

Heu oui les csv... mais en fait, le but final c'est de créer une base mysql (ou autre). Du coup, je suis confronté à un autre problème, l'importation dans mysql mais là c'est hors sujet...

En 3heures, c'est 350 fichiers que je traite... J'ai estimé 25h pour les 2000 !!
Si j'arrive à 3h pour 2000, je hurle de joie!!

Pour les "Select" c'est un oubli de ma part !! Merci de l'avoir remarqué!

Je suis preneur de toute remarque d'ailleurs !

à tester ceci,

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
Option Explicit
 
Sub Main()
    Const Rep = "C:\Documents and Settings\*****\Bureau\*****\" ' le répertoire contenant les fichiers..
    Dim TheFile As String 'Variable pour le nom du fichier
    Dim NewFile As String
    Dim DateDeb As Date, DateFin As Date, TempsTot As Date
    'Chrono
    DateDeb = Time
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    TheFile = Dir(Rep & "*.xlsx")   'Listing des fichier Excel...
    While TheFile <> "" 'Tant que non vide
        Workbooks.Open (Rep & TheFile) 'Ouverture du fichier
        Call Epuration_fichiers_Main
        'Epuration du nom du fichier (en enlève l'extention *.xlsx
        NewFile = Left(TheFile, InStrRev(TheFile, ".") - 1)
        ChDir "C:\Documents and Settings\*****\Bureau\*****"
        ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False
        ActiveWindow.Close
        TheFile = Dir 'Fichier suivant
    Wend
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'Fin du chrono
    DateFin = Time
    TempsTot = DateFin - DateDeb
 
    MsgBox "Traitement terminé" & vbCrLf & TempsTot
 
End Sub
 
Sub Epuration_fichiers_Main()
 
    Rows("1:1").Delete
    Columns("I:J").Delete
    'Suppression des lignes où il manque le CP ou la ville ou les deux
    Call Suppression_Lignes_inexploitables("C:D")
    'Suppression des doublons
    Call Suppression_doublons
    'Format "téléphone pour les case E,F,G
    Application.ErrorCheckingOptions.BackgroundChecking = False    'Suppression des balises actives
    Column("E:G").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
 
 
End Sub
Sub Suppression_doublons()
 
    'Les déclarations des variables
    Dim sNumTel As String, sNom As String, sAdd As String, iCP As String, sChaine As String
    Dim iNb_Lignes As Long, iPos1 As Byte, iNombreCell_1 As Long, iNombreCell_2 As Long
    Dim rCible As Range, iLigne As Long, rRgeA As Range, rRgeB As Range, i As Long
 
    iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
 
    'Boucle sur toutes les lignes du fichier
    For i = iNb_Lignes To 1 Step -1
        'Transformation des minuscules en majuscules dans les colonnes A,B,D,I
        Range("A", i).Value = Replace(Range("A", i).Value, Range("A", i).Value, UCase(Range("A", i).Value))
        Range("B", i).Value = Replace(Range("B", i).Value, Range("B", i).Value, UCase(Range("B", i).Value))
        Range("D", i).Value = Replace(Range("D", i).Value, Range("D", i).Value, UCase(Range("D", i).Value))
        Range("I", i).Value = Replace(Range("I", i).Value, Range("I", i).Value, UCase(Range("I", i).Value))
        'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
        '#####################################
        If Left(Range("E" & i).Value, 2) = "06" Then
            If Range("G" & i).Value = "" Then
                Range("G" & i).Value = Range("E" & i).Value
            Else
                Range("E" & i).ClearContents
            End If
        End If
 
        'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
        'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
        sChaine = Range("B" & i).Value
        iPos1 = InStrRev(sChaine, "-")
        If iPos1 > 0 Then
            Range("B" & i).Value = Mid(sChaine, iPos1 + 1)
        End If
 
        'Suppression des doublons
        sNumTel = Range("E" & i).Value
        sNom = Range("A" & i).Value
        iCP = Range("C" & i).Value
        sAdd = Range("B" & i).Value
 
        If sNumTel <> "" Then
            Set rCible = Range("E1:E" & i).Find(what:=sNumTel, lookat:=xlWhole)
            If Not rCible Is Nothing Then
            iLigne = rCible.Row
            'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
                If Range("A" & iLigne).Value = sNom And Range("B" & iLigne).Value = sAdd And Range("C" & iLigne).Value = iCP Then
                    Set rRgeA = Range("A" & i & ":K" & i)
                    Set rRgeB = Range("A" & iLigne & ":K" & iLigne)
                        iNombreCell_1 = Application.WorksheetFunction.CountBlank(rRgeA)
                        iNombreCell_2 = Application.WorksheetFunction.CountBlank(rRgeB)
                    Set rRgeA = Nothing
                    Set rRgeB = Nothing
                    'La ligne contenant le plus de colonne vide est supprimée
                    If iNombreCell_1 > iNombreCell_2 Or i <> iLigne Then
                        Range("A" & iLigne).EntireRow.Delete
                    End If
                End If
            End If
            Set rCible = Nothing
        End If
    Next i
End Sub
 
Public Sub Suppression_Lignes_inexploitables(rRge As String)
Dim rCible As Range
Dim iNb_Lignes As Long
 
iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
If iNb_Lignes > 1 Then
    Do
        Set rCible = Range(rRge).Find("", lookat:=xlWhole, SearchOrder:=xlByRows)
        If Not rCible Is Nothing Then
            If rCible.Row > iNb_Lignes Then Exit Do
            iNb_Lignes = iNb_Lignes - 1
            rCible.EntireRow.Delete
        End If
    Loop
End If
End Sub

Re Edité: Public Sub Suppression_Lignes_inexploitables

15/11/2009, 20h13
laetitia

bonjour yolak l' ami mercatog le forum comme je comprends pour arriver a 25h pour 2000fichiers ton estimation!!!!
question une: en moyenne tu travailles sur combien de colonnes tu t arretes toujours a colonne K ???

question2: au niveau des lignes combien de lignes en moyenne ????

en question3: pourquoi si doublons tu supprimes la ligne la moins pleine
quel est l'importance ??? une grosse perte de temps a ce niveau la avec ton code
question4: en moyenne ouverture fichier correction fermeture & sauvegarde 45 secondes par fichier sur ton estimation c'est tres long meme sur un fichier avec 65000 lignes 11 colonnes avec le peut de modif que tu as a faire je trouve cela tres long tu travailles sur quoi comme config....

par curiosite si tu pouvais en dire plus

leti a+
16/11/2009, 00h11
mondev

1 pièce(s) jointe(s)

Salut,

Citation:

Envoyé par laetitia

...

45 secondes par fichier sur ton estimation c'est tres long meme sur un fichier avec 65000 lignes 11 colonnes avec le peut de modif que tu as a faire

...

J'allais le dire!

Sinon, après avoir répondu a laetitia (une réponse que j'attends aussi), est ce que tu as essayé sans ça :

Code:

ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False

parce que je me demande si ce n'est pas à cause de l'écriture sur le disque !!!
si tu ne la pas fait, peux tu le faire stp ? avec une dizaine de fichiers, ça ira plus vite, et puis ça te permettra surtout de savoir où... il faut optimiser

Après, ya 2 chose que je te recommande :
1/ Bien typer tes variables
2/ Et surtout, essaie d'utiliser les tableau au lieu de travailler directement sur la feuille
Un ptit exemple (fichier attaché en bas):
Chez moi c'est 7secondes sur les cellules (Feuil2) contre 2secondes avec un tableau (Feuil1)
La première fois j'ai déclaré mon tableau comme Variant, et j'ai du attendre 2minutes parce que j'avais dépassé mes 512Mo de RAM donc il faut penser à ça aussi et bien typer les variables

J' (nous?!) attends surtout que tu essaies sans l'enregistrement des csv si c'est possible...

A+
16/11/2009, 19h05
Yolak

Bonjour bonjour les gens!!!

Merci pour ces renseignements !!!

Je vais répondre à toutes vos questions
Déjà, mercatog, j'ai pas testé ton code, je vais le tester plus tard
pour laetitia:

Citation:

question une: en moyenne tu travailles sur combien de colonnes tu t arretes toujours a colonne K ???

En fait j'ai 11 colonnes au début et j'en supprime deux.

Citation:

question2: au niveau des lignes combien de lignes en moyenne ????

Ca c'est archi-variable !!! Ca peut etre une centaine comme presque 68000 (XL-2007)

Citation:

en question3: pourquoi si doublons tu supprimes la ligne la moins pleine
quel est l'importance ??? une grosse perte de temps a ce niveau la avec ton code

Chaque ligne correspond à une personne (nom, mail, adresse, tel) et je veux garder les lignes avec le plus de renseignements...

Citation:

question4: en moyenne ouverture fichier correction fermeture & sauvegarde 45 secondes par fichier sur ton estimation c'est tres long meme sur un fichier avec 65000 lignes 11 colonnes avec le peut de modif que tu as a faire je trouve cela tres long tu travailles sur quoi comme config....

J'ai un méga pc avec une très très bonne config (je passe beaucoup de temps sur les jeux gourmands) Ce qui prend le plus de temps c'est le traitement ligne par ligne

Citation:

par curiosite si tu pouvais en dire plus

Que veux-tu savoir???
Mon but final, c'est de créer une base de donnée avec une table qui contient toutes les lignes de tout mes classeurs (en tout, environ 4 millions d'enregistrement !).

Pour mondev:

Citation:

Sinon, après avoir répondu a laetitia (une réponse que j'attends aussi), est ce que tu as essayé sans ça :
Code :

ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False

parce que je me demande si ce n'est pas à cause de l'écriture sur le disque !!!
si tu ne la pas fait, peux tu le faire stp ? avec une dizaine de fichiers, ça ira plus vite, et puis ça te permettra surtout de savoir où... il faut optimiser

Je vais tester, mais je ne pense pas que ce soit cette opération qui prenne le plus de temps. J'ai pu remarqué que le traitement est proportionnellement plus long selon la taille du fichier.

Citation:

Après, ya 2 chose que je te recommande :
1/ Bien typer tes variables
2/ Et surtout, essaie d'utiliser les tableau au lieu de travailler directement sur la feuille
Un ptit exemple (fichier attaché en bas):
Chez moi c'est 7secondes sur les cellules (Feuil2) contre 2secondes avec un tableau (Feuil1)
La première fois j'ai déclaré mon tableau comme Variant, et j'ai du attendre 2minutes parce que j'avais dépassé mes 512Mo de RAM donc il faut penser à ça aussi et bien typer les variables

Pour les variables, je pense être au plus proche de la réalité
Pour l'histoire des tableau, je vais regarder ça avec ton exemple.

Je vais faire mes petits tests et je reviens vous dire tout ça.
En attendant, merci à tous de tenter de m'aider !!! :D

Re-Bonjour:
Premier test:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Suppression_Lignes_inexploitables(rRge As String)
Dim rCible As Range
Dim trouv As Boolean
 
Do
    Set rCible = Range(rRge).Find(what:="", lookat:=xlWhole)
    If Not rCible Is Nothing Then
        rCible.EntireRow.Delete
        trouv = True
    Else
        trouv = False
    End If
    Set rCible = Nothing
Loop Until Not trouv

Ca ne fonctionne pas, ça génère une boucle infinie...

pourrais-tu expliquer ton code (fichier joint) stp ???
Y'a pas de commentaires

Code:

1
2
3
4
5
6
7
8
9
10
Private Sub Worksheet_Activate()
    Dim i As Double, aTime As Date, aTab() As Double
    aTime = Time
    ReDim aTab(1 To Me.Cells.Count)
    For i = 1 To UBound(aTab)
        aTab(i) = Rnd()
    Next i
    Range("A1:A" & Me.Rows.Count) = aTab
    MsgBox CDate(Time - aTime)
End Sub

EDIT: J'ai avancé, je revu ma façon de penser:
Dans ma boucle de recherche de sNumTel, j'ai modifié ceci:
Plutôt que de chercher a chaque fois si le numéro de tél de la cellule active existe autre part sur la feuille, j'ai trié la feuille par ordre croissant selon la colonne des numéros de tél et j'ai testé la condition suivante:
Si la valeur de la cellule active est la même que celle de la cellule précédente, alors j'exécute mon traitement (suppression de la ligne la moins remplie)
En code ça donne ça

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Private Sub Suppression_doublons()
 
    'Les déclarations des variables
    Dim sNumTel As String, sNom As String, sAdd As String, iCP As String, schaine As String
    Dim iNb_Lignes As Long, iPos1 As Long, iNombreCell_1 As Long, iNombreCell_2 As Long
    Dim rCible As Range, iLigne As Long, rRgeA As Range, rRgeB As Range, i As Long
 
 
    'initialisation des variables
    iPos1 = 0
 
    iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
 
 
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("E2:E" & iNb_Lignes) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
        .SetRange Range("A1:K448")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'Boucle sur toutes les lignes du fichier
    For i = iNb_Lignes To 1 Step -1
 
        'Transformation des minuscules en majuscules dans les colonnes A,B,D,I
        Call Majuscule("A", i)
        Call Majuscule("B", i)
        Call Majuscule("D", i)
        Call Majuscule("I", i)
 
        'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
        '#####################################
        If Left(Range("E" & i).Value, 2) = "06" Then
            If Range("G" & i).Value = "" Then
                Range("E" & i).Cut Range("G" & i)
            Else
                Range("E" & i).ClearContents
            End If
        End If
 
        'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
        '#####################################
        'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
        schaine = Range("B" & i).Value
        iPos1 = InStrRev(schaine, "-")
        If iPos1 <> 0 Then
            Range("B" & i).Value = Mid(schaine, iPos1 + 1)
        End If
 
 
        'Mise en majuscule des champs
        schaine = Range("A" & i).Value
        Range("A" & i).Value = UCase(schaine)
        schaine = Range("A" & i).Value
        Range("A" & i).Value = UCase(schaine)
 
 
        'Suppression des doublons
        '#####################################
 
        sNumTel = Range("E" & i).Value
        sNom = Range("A" & i).Value
        iCP = Range("C" & i).Value
        sAdd = Range("B" & i).Value
 
        If i <> 1 Then
            If sNumTel = Range("E" & i - 1).Value Then
                iLigne = i + 1
            'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
                If Range("A" & iLigne).Value = sNom And Range("B" & iLigne).Value = sAdd And Range("C" & iLigne).Value = iCP Then
                    Set rRgeA = Range("A" & i & ":K" & i)
                    Set rRgeB = Range("A" & iLigne & ":K" & iLigne)
                    iNombreCell_1 = Application.WorksheetFunction.CountBlank(rRgeA)
                    iNombreCell_2 = Application.WorksheetFunction.CountBlank(rRgeB)
 
                    'La ligne contenant le plus de colonne vide est supprimée
                    If iNombreCell_1 > iNombreCell_2 Then
                        Range("A" & iLigne).EntireRow.Delete
                    Else
                        Range("A" & i).EntireRow.Delete
                    End If
                End If
            End If
        End If
    Next i
End Sub

Et c'est ULTRA plus rapide !!!!!
Je refait mon test sur les 350 fichiers et je reviens mettre la balise résolu si ça me convient !

Merci à tous

J'ai rectifié

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub Suppression_Lignes_inexploitables(rRge As String)
Dim rCible As Range
Dim iNb_Lignes As Long
 
iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
If iNb_Lignes > 1 Then
    Do
        Set rCible = Range(rRge).Find("", lookat:=xlWhole, SearchOrder:=xlByRows)
        If Not rCible Is Nothing Then
            If rCible.Row > iNb_Lignes Then Exit Do
            iNb_Lignes = iNb_Lignes - 1
            rCible.EntireRow.Delete
        End If
    Loop
End If
End Sub

Oui, c'est plus rapide ta dernière pensée
Encore, si tu regardais aussi ma dernière proposition, tu peux gagner encore certaines secondes utiles

16/11/2009, 23h58
Yolak

Je suis enfin parvenu a trouver ce qui ralentissait mon code:
c'est ce fichu "find" !
Je suis passé d'une estimation de 25h à une estimation de 3h
Mission accomplie!
Merci à tous, vous m'avez été d'une immense aide!!!
Vive le forum, vive la programmation, vive vous, et vive moi (quoi?)

Salut,

J'arrive un peu tard...

Citation:

pourrais-tu expliquer ton code (fichier joint) stp ???
Y'a pas de commentaires

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Activate()
    Dim i As Double
    Dim aTime As Date 'Chrono
    Dim aTab() As Double 'Tableau vide
 
    aTime = Time 'Chroro = maintenant (l'heure)
    ReDim aTab(1 To Me.Cells.Count) 'redimensionner le tableau (de 1 a nbr de lignes)
    For i = 1 To UBound(aTab) 'de 1 a dernier index du tableau (nbr de lignes)
        aTab(i) = Rnd() 'tableau(i) = nombre au hasard (fonction Rnd:random)
    Next i 'i suivant
    Range("A1:A" & Me.Rows.Count) = aTab 'plage A:A = tableau
    MsgBox CDate(Time - aTime) 'CDate:fonction de conversion de type
End Sub

Voilà, je voulais pas laissé ça sans réponse

Bonne continuation
:ccool:

17/11/2009, 18h23
Yolak

Citation:

Envoyé par mondev

Voilà, je voulais pas laissé ça sans réponse

Quel bon esprit !!
Merci et a bientôt

bonjour tous une macro a tester

Code:

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
Sub Main()
    Const Rep = "C:\Documents and Settings\*****\Bureau\*****\" ' le répertoire contenant les fichiers..
    Dim TheFile As String 'Variable pour le nom du fichier
    Dim LaDateData As Date, NewFile As String
    Dim DateDeb As Date, DateFin As Date, TempsTot As Date
    DateDeb = Time
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
        TheFile = Dir(Rep & "*.xlsx")
    While TheFile <> ""
       Workbooks.Open (Rep & TheFile)
    essai2 'macro
     NewFile = Left(TheFile, InStrRev(TheFile, ".") - 1)
         ChDir "C:\Documents and Settings\*****\Bureau\*****"
            ActiveWorkbook.SaveAs Filename:= _
                "C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV _
                , CreateBackup:=False
        ActiveWindow.Close
       TheFile = Dir
    Wend
 .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
    DateFin = Time
    TempsTot = DateFin - DateDeb
     MsgBox ("Traitement terminé" & vbCrLf & TempsTot)
 End Sub

Code:

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
Sub essai2()
Dim t As Variant, T2(), x As Long, i As Long, k As Long
On Error Resume Next
Range("a2:i" & ActiveSheet.UsedRange.Rows.Count).Sort Key1:=Range("e2"), Order1:=xlAscending, Header:=xlGuess
Range("m2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(RC[-14]:RC[-4],"""")"
Range("m2:m" & Cells.Find("*", , , , , xlPrevious).Row).FillDown
t = Range("a2:m" & Range("a65536").End(xlUp).Row)
x = 1
For i = 1 To UBound(t)
If Left(t(i, 5), 2) = "06" Then t(i, 7) = t(i, 5): t(i, 5) = ""
t(i, 2) = Mid(t(i, 2), InStrRev(t(i, 2), "-") + 1)
t(i, 1) = UCase(t(i, 1)): t(i, 2) = UCase(t(i, 2)): t(i, 4) = UCase(t(i, 4)): t(i, 9) = UCase(t(i, 9))
t(i, 10) = t(i, 1) & t(i, 2) & t(i, 3) & t(i, 5)
t(i, 11) = t(i - 1, 1) & t(i - 1, 2) & t(i - 1, 3) & t(i - 1, 5)
If t(i, 10) <> t(i, 11) And t(i, 3) <> "" And t(i, 4) <> "" Then
t(i, 10) = "ok"
End If
If t(i, 10) = t(i, 11) And t(i, 3) <> "" And t(i, 4) <> "" Then
If Range("m" & i).Value < Range("m" & i - 1).Value Then
 t(i, 10) = "ok": t(i - 1, 10) = ""
End If: End If
If t(i, 10) = "ok" Then
ReDim Preserve T2(1 To 9, 1 To x)
For k = 1 To 9: T2(k, x) = t(i, k): Next k: x = x + 1: End If: Next i
Cells.Clear
Range("a2").Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2)
Application.ErrorCheckingOptions.BackgroundChecking = False
Range("E:G").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
Erase t, T2
End Sub

17/11/2009, 20h59
Yolak

Wow lol !
Un peu de commentaires ou d'explications nous ferais du bien je pense !!
:aie:
Merci!