Discussion :

[wagonvba]

Bonjour,

J'ai un tableau de ce genre là : http://i.imgur.com/e36kd.png
Avec 6000 lignes.

J'ai plusieurs opérations à effectuer :
- Dans la colonne C et E, remplacer "a" par "b" et "c" par "d"
- Supprimer les lignes où la cellule de la colonne C est vide.
- Supprimer les lignes où la cellule de la colonne B vaut "S" et que la cellule de la colonne "H" vaut "x".
- Supprimer les lignes où la cellule de la colonne B vaut "A" et que la cellule juste en dessous ou juste au dessus vaut "S" et que les cellules des colonnes D,E et H soient les mêmes.
- Enfin supprimer les doublons sur toutes les colonnes.

J'ai fait ce programme :

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
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
128
129
130
131
Sub TABLEAU_TRAITEMENT()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks.Open("chemin\tableau.xls")
Set ws = wb.Worksheets(1)
 
Dim cellule_en_cours As String
Dim ligne As Integer
 
cellule_en_cours = "c"
ligne = 0
Do While cellule_en_cours <> ""
ligne = ligne + 1
cellule_en_cours = Cells(ligne, 1).Value
Loop
 
' On cherche la dernière ligne du tableau.
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("D2:D" & ligne), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("A2:A" & ligne), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(1).Sort
        .SetRange Range("A1:M" & ligne)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    Columns("A:M").EntireColumn.AutoFit
 
   Range("A1:M" & ligne).Select
    Selection.NumberFormat = "m/d/yyyy h:mm"
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
 
 
 
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
' J'ai juste aligné à gauche, mis la bonne police, le bon format et ajusté la taille des colonnes.
 
 
 
Dim i As Integer
 
 
For i = 2 To ligne
 
Range("A" & i).Activate
Range("A" & i).Select
Cells(i, 14).Value = "Balayé"
 
' Pour voir par quelles lignes passe le programme.
 
    If Cells(i, 3).Value = "a" Then
        Cells(i, 3).Value = "b"
    End If
 
    If Cells(i, 3).Value = "c" Then
        Cells(i, 3).Value = "d"
    End If
 
    If Cells(i, 5).Value = "a" Then
        Cells(i, 5).Value = "b"
    End If
 
    If Cells(i, 5).Value = "c" Then
        Cells(i, 5).Value = "d"
    End If
 
    If Cells(i, 2).Value = "A" Then
            If Cells(i - 1, 2).Value = "S" And Cells(i - 1, 3).Value = Cells(i, 3).Value And Cells(i - 1, 4).Value = Cells(i, 4).Value And Cells(i - 1, 5).Value = Cells(i, 5).Value Then
            Cells(i, 1).EntireRow.Delete
            ligne = ligne - 1
 
            End If
 
            If Cells(i + 1, 2).Value = "S" And Cells(i + 1, 3).Value = Cells(i, 3).Value And Cells(i + 1, 4).Value = Cells(i, 4).Value And Cells(i + 1, 5).Value = Cells(i, 5).Value Then
            Cells(i, 1).EntireRow.Delete
            ligne = ligne - 1
 
            End If
    End If
 
    If Cells(i, 8).Value = "x" Then
        If Cells(i, 2).Value = "S" Then
            Cells(i, 1).EntireRow.Delete
            ligne = ligne - 1
 
        End If
    End If
 
    If Cells(i, 3).Value = "" Then
    Cells(i, 1).EntireRow.Delete
 
    End If
 
 
Next
 
ActiveSheet.Range("$A$1:$N$" & ligne).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
 
ActiveCell(1, 1).Select
 
 
 
End Sub

Et là, c'est la cata. Toutes les lignes ne sont pas forcément balayées. Le traitement s'effectue sur certaines lignes et pas d'autres. Des lignes balayées ne sont pas traitées. Le seul truc qui fonctionne, c'est les doublons.

(Désolé pour les données, confidentielles.)

Donc je viens quérir votre aide, merci d'avances car je suis totalement perdu.

[mercatog]

D'abord pour supprimer des lignes en boucle on part de la dernière ligne et on remonte

Code :

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

For i = ligne to 1 step -1

PS: Plusieurs choses à modifier dans ton code pour être optimisé.

[patricktoulon]

bonjour

deja pour commencer quand on traite un grand nombre de ligne on peut opter pour travailler sur des tableau(variables tableau)

ainsi on pedale pas pour modifier une cellule

donc le principe c'est de mettre toute ta colonne "C" dans un tableau
ainsi que ta colonne "E"

comparer chaque element du tableau et changer le a en b et le c en d

et transposer les tableau sur le range dont ils sont issus

exemple

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
 
Sub remplace_les_a_et_b()
    t = Timer
    Dim TabloS1 As Variant
    Dim tabloS2 As Variant
    TabloS1 = Range(Sheets(1).Range("c1"), Sheets(1).Cells(Rows.Count, 3).End(xlUp).Offset(0, 1))
    tabloS2 = Range(Sheets(1).Range("e1"), Sheets(1).Cells(Rows.Count, 5).End(xlUp).Offset(0, 1))
    For i = 1 To UBound(TabloS1, 1)
        'remplacement des a et b dans le tableau colonne "c"
        If TabloS1(i, 1) = "a" Then TabloS1(i, 1) = "b"
        If TabloS1(i, 1) = "c" Then TabloS1(i, 1) = "d"
        'remplacement des a et b dans le tableau colonne "E"
        If tabloS2(i, 1) = "a" Then tabloS2(i, 1) = "b"
        If tabloS2(i, 1) = "c" Then tabloS2(i, 1) = "d"
    Next i
    'on transpose les tablos dans la plage dont ils sont issus
    Range(Sheets(1).Range("c1"), Sheets(1).Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)) = TabloS1
    Range(Sheets(1).Range("e1"), Sheets(1).Cells(Rows.Count, 5).End(xlUp).Offset(0, 1)) = tabloS2
MsgBox Timer - t
 
End Sub

j'ai mis un msgbox qui te donne la durrée de l'operation en millieme e seconde

voila pour l'exemple

au plaisir

on peu aussi faire le tout en une fois
changer les a en c les c en d et supprimer toute les ligne dont la cellules en colonne b est vide

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
 
Sub remplace_les_A_en_B_ou_les_C_en_D()
'Application.ScreenUpdating = False
    t = Timer
    Dim tabloC As Variant
    tabloC = Range(Sheets(1).Range("a1"), Sheets(1).Cells(Rows.Count, 5).End(xlUp).Offset(0, 1))
    For i = 1 To 100    'UBound(tabloC)
        'remplacement des a et b dans le tableau colonne "c"
        If tabloC(i, 3) = "a" Then tabloC(i, 3) = "b"
        If tabloC(i, 3) = "c" Then tabloC(i, 3) = "d"
        If tabloC(i, 5) = "a" Then tabloC(i, 5) = "b"
        If tabloC(i, 5) = "c" Then tabloC(i, 5) = "d"
    Next i
    'on transpose les tablos dans la plage dont ils sont issus
    Range(Sheets(1).Range("a1"), Sheets(1).Cells(Rows.Count, 5).End(xlUp).Offset(0, 1)) = tabloC
    'pour suprimer les ligne ou en colonne C il y a rien il y a plusieur facon
    On Error Resume Next
    'celle ci:
    [C:C].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
'ou celle la:
'Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox Timer - t
 
End Sub

au plaisir

finalement on pourrais tout faire dans la meme boucle

regarde commant je m'y suis pris pour la colonne b et h

je teste dans le tableau si le tabloc( 1,2) ="S"et tabloc( i,8)="X"
si cette condition est remplie alors je vide le tabloc(i,3)qui corespond a la colonne "C" dans ton sheets
et donc comme a la fin je vire toute les ligne vides en colonne "C"
je fait d'une pierre 2 coup

tu peut essayer de faire la meme chose dans la boucle pour ta derniere condition
si tu n'y arrive pas je te le ferais

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 remplace_les_A_en_B_ou_les_C_en_D()
'Application.ScreenUpdating = False
    t = Timer
    Dim tabloC As Variant
    tabloC = Range(Sheets(1).Range("a1"), Sheets(1).Cells(Rows.Count, 8).End(xlUp).Offset(0, 1))
    For i = 1 To 100    'UBound(tabloC)
        'remplacement des a et b dans le tableau colonne "c"
        'si la cellule "B" = "s" et la cellule "H" = "x" on  vide la cellule C  puisque l 'on delete les ligne vide en c
        If tabloC(i, 2) = "s" And tabloC(i, 8) = "x" Then tabloC(i, 3) = ""
        If tabloC(i, 3) = "a" Then tabloC(i, 3) = "b"
        If tabloC(i, 3) = "c" Then tabloC(i, 3) = "d"
        If tabloC(i, 5) = "a" Then tabloC(i, 5) = "b"
        If tabloC(i, 5) = "c" Then tabloC(i, 5) = "d"
    Next i
    'on transpose les tablos dans la plage dont ils sont issus
    Range(Sheets(1).Range("a1"), Sheets(1).Cells(Rows.Count, 8).End(xlUp).Offset(0, 1)) = tabloC
    'pour suprimer les ligne ou en colonne b il y a rien il y a plusieur facon
    On Error Resume Next
    'celle ci:
    [c:c].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
    'ou celle la:
    'Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox Timer - t
 
End Sub

au plaisir

j'oubliais!!!!!

dans le code que je t'ai donné pour mes test je limitais le travail a 100 lignes

il te faut les débloqué pour aller jusqu'au bout
enleve le 100 et l'apostrophe

Code :

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

For i = 1 To 100'UBound(tabloC)

au plaisir

re
tiens voila la derniere condition avant de supprimer les doublons

a metre au debut de la boucle

Code :

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

1
2
3
'- Supprimer les lignes où la cellule de la colonne B vaut "A" et que la _
       'cellule juste en dessous ou juste au dessus vaut "S" et que les cellules des colonnes D,E
        If tabloC(i, 2) = "a" And tabloC(i + 1, 2) = "S" And tabloC(i, 4) = tabloC(i, 5) And tabloC(i, 5) = tabloC(i, 8) Then tabloC(i, 3) = ""

maintenant qu'appelle tu les doublons dans quelle plage ??????

[wagonvba]

Je vais étudier ça mais vu que je m'y connais pas trop, ça va être coton, merci !

[patricktoulon]

bonsoir

il suffit de s y mettre

j'ai fait un petit oubli dans l'enoncer de la boucle

Code :

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

for i=1 to ubound(tabloc)-1

sinon avec la ligne suppression par raport a b, d,e,h tu auras un bug a la derniere ligne utilisée de ton tableau

mille excuse pour cette oubli

je n'ai toujour pas eu ma reponse concernant les doublons ??

au plaisir

re
je viens de faire l'essais sur 65536 lignessoit une feuille en entier et le tri a duré 14,3 secondes
c'est l'avantage de travailler sur des variables tableaux

au plaisir

[wagonvba]

Merci pour ton code, j'ai tout compris et je trouve ta façon de coder très intelligente ! Pour les doublons c'était les lignes qui étaient exactement les mêmes mais il existe déjà une fonction que j'ai utilisée

Code :

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

ActiveSheet.Range("$A$1:$N$" & ligne).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo

C'était très gentil de me venir en aide et tu as été très utile ! À la prochaine ^^

Et... Mince !
Cette ligne

Code :

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

If tabloC(i, 2) = "a" And tabloC(i + 1, 2) = "S" And tabloC(i, 4) = tabloC(i, 5) And tabloC(i, 5) = tabloC(i, 8) Then tabloC(i, 3) = ""

Me fait une erreur 9 et je vois pas du tout pourquoi ><