Discussion :

[azzouzze]

bonjour,

J'ai un gros problème de doublons à faire et je rame.
Mon problème est le suivant. Si les lignes ont les mêmes valeurs en B,C,D et E; je regarde la colonne K de mon tableau. celle qui à la valeur A est gardé, sinon C sinon D et finalement si c P on garde celle qui à le moins de cellules vides dans la ligne.

Merci d'avance

PS: j ai trouvé un bout de macro pas mal mais j arrive pas a mettre le critère P D C A

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
Sub DoublonsLignesCompletes()
Dim Cell As Range
Dim Ligne As Integer, I As Integer, M As Integer, n As Integer
Dim j As Byte, k As Byte
Dim Tableau(), Tableau2()
Dim Cible As String, Resultat As String
Dim U As Boolean
Dim Bouton As Object
 
 
Ligne = Range("A65536").End(xlUp).Row ' derniere ligne non vide colonne A
M = 1
n = 1
ReDim Preserve Tableau(M) 'tableau valeurs uniques colonne A
ReDim Preserve Tableau2(4, n) ' tableau pour numero de lignes doublons
 
Application.ScreenUpdating = False
For Each Cell In Range("A5:A" & Ligne) ' adapter selon position tableau dans feuille
U = False
Cible = Cell
For j = 2 To 25 ' adapter selon nombre de colonnes
Cible = Cible & Cell.Offset(0, j)
Next j
For I = 1 To M
If Cible = Tableau(I - 1) Then
Rows(Cell.Row).Hidden = True
For k = 1 To 4
Tableau2(k - 1, n - 1) = Cells(Cell.Row, k) ' recupere ligne quand un doublon est detecté
Next k
n = n + 1
ReDim Preserve Tableau2(4, n)
U = True
End If
Next I
 
If Tableau(M - 1) = "" And U = False Then
Tableau(M - 1) = Cible ' remplissage tableau valeurs uniques si pas de doublon détecté
M = M + 1
ReDim Preserve Tableau(M)
End If
Next Cell
 
Workbooks.Add (1) 'creation classeur resultat
Set Bouton = Range("F5:G7")
 
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, Bouton.Left, Bouton.Top, Bouton.Width, Bouton.Height)
.Name = "bouton" ' changer le nom du shapes
.TextFrame.Characters.Text = "Supprimer le classeur " & Chr(10) & " résultat . " 'texte dans le shapes
.Fill.ForeColor.SchemeColor = 42 'couleur shapes
.OnAction = "SupprimerResultat" 'affecter une macro
End With
 
ActiveSheet.Name = "Doublons option " & NomFeuille
With ActiveSheet.Range("A1:D1")
.Font.Bold = True
.Interior.ColorIndex = 35
End With
ActiveSheet.Range("A1") = "info1"
ActiveSheet.Range("B1") = "info2"
ActiveSheet.Range("C1") = "info3"
ActiveSheet.Range("D1") = "info4"
 
For I = 1 To n - 1 ' insertion doublons dans feuille 2
For k = 1 To 4
ActiveSheet.Cells(I + 1, k) = Tableau2(k - 1, I - 1)
Next k
Next I
 
With Columns("A: D ") 'mise en page
.AutoFit
.HorizontalAlignment = xlCenter
End With
 
Application.ScreenUpdating = True
'nload Dedouble
 
End Sub
 
Sub test()
Dim n As Integer
Dim col As Collection
Set col = New Collection
For n = Range("A65536").End(xlUp).Row To 2 Step -1
On Error GoTo suite
 atester = Range("A" & n) & Range("B" & n) & Range("C" & n) & Range("D" & n)
 col.Add atester, CStr(atester)
suite:
If err.Number = 457 Then
Rows(n).Delete
Resume Next
End If
Next n
End Sub

[ouskel'n'or]

Bonjour Azzouzze, j'ai remplacé les balises Quote par Code mais l'indentation de tes lignes a disparu rendant ton code illisible. Peux-tu corriger ta discussion en remettant le code indenté.
Pour le baliser, sélection du code + 1 clic sur # en mode d'édition.
Pour corriger ta discussion -> Bouton éditer en bas de ton message.
A+

[ouskel'n'or]

Si les lignes ont les mêmes valeurs en B,C,D et E; je regarde la colonne K de mon tableau. celle qui à la valeur A est gardé, sinon C sinon D

Tu pourrais préciser un ou deux points ?
Veux-tu dire
si la cellule de la colonne K = Cellule de la colonne A, on garde la ligne
sinon si Range("K" & NoLigne) = Range("B" & NoLigne), on garde la ligne
sinon si Range("K" & NoLigne) = Range("C" & NoLigne), on garde la ligne
sinon si Range("K" & NoLigne) = Range("D" & NoLigne), on garde la ligne
sinon si Range("K" & NoLigne) = Range("E" & NoLigne), on garde la ligne
Ensuite, tu mets

et finalement si c P on garde celle qui à le moins de cellules vides dans la ligne.

Partout dans la ligne ou seulement à droite ou seulement à gauche de la / des cellule(s) renseignée(s) ?

PS - Ne m'attends pas ce soir ->

[azzouzze]

Merci de ton aide.
tu a tout à fait compris. on regarde les doubons de la facon suivante:
1) celui qui contiend A dans sa colonne k on le garde
2) sinon s il contiend C on le garde
3) sinon D
4) sinon P et le minimum de cellule vide ( indiqué en colonne L ) avant la colonne K.

merci beaucoup pour ton aide. j en ai trop besoin pour finir mon prog.

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
Sub DoublonsLignesCompletes()
Dim Cell As Range
Dim Ligne As Integer, I As Integer, M As Integer, n As Integer
Dim j As Byte, k As Byte
Dim Tableau(), Tableau2()
Dim Cible As String, Resultat As String
Dim U As Boolean
Dim Bouton As Object
 
 
Ligne = Range("A65536").End(xlUp).Row ' derniere ligne non vide colonne A
M = 1
n = 1
ReDim Preserve Tableau(M) 'tableau valeurs uniques colonne A
ReDim Preserve Tableau2(4, n) ' tableau pour numero de lignes doublons
 
Application.ScreenUpdating = False
For Each Cell In Range("A5:A" & Ligne) ' adapter selon position tableau dans feuille
U = False
Cible = Cell
For j = 2 To 25 ' adapter selon nombre de colonnes
Cible = Cible & Cell.Offset(0, j)
Next j
For I = 1 To M
If Cible = Tableau(I - 1) Then
Rows(Cell.Row).Hidden = True
For k = 1 To 4
Tableau2(k - 1, n - 1) = Cells(Cell.Row, k) ' recupere ligne quand un doublon est detecté
Next k
n = n + 1
ReDim Preserve Tableau2(4, n)
U = True
End If
Next I
 
If Tableau(M - 1) = "" And U = False Then
Tableau(M - 1) = Cible ' remplissage tableau valeurs uniques si pas de doublon détecté
M = M + 1
ReDim Preserve Tableau(M)
End If
Next Cell
 
Workbooks.Add (1) 'creation classeur resultat
Set Bouton = Range("F5:G7")
 
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, Bouton.Left, Bouton.Top, Bouton.Width, Bouton.Height)
.Name = "bouton" ' changer le nom du shapes
.TextFrame.Characters.Text = "Supprimer le classeur " & Chr(10) & " résultat . " 'texte dans le shapes
.Fill.ForeColor.SchemeColor = 42 'couleur shapes
.OnAction = "SupprimerResultat" 'affecter une macro
End With
 
ActiveSheet.Name = "Doublons option " & NomFeuille
With ActiveSheet.Range("A1:D1")
.Font.Bold = True
.Interior.ColorIndex = 35
End With
ActiveSheet.Range("A1") = "info1"
ActiveSheet.Range("B1") = "info2"
ActiveSheet.Range("C1") = "info3"
ActiveSheet.Range("D1") = "info4"
 
For I = 1 To n - 1 ' insertion doublons dans feuille 2
For k = 1 To 4
ActiveSheet.Cells(I + 1, k) = Tableau2(k - 1, I - 1)
Next k
Next I
 
With Columns("A:D") 'mise en page
.AutoFit
.HorizontalAlignment = xlCenter
End With
 
Application.ScreenUpdating = True
'nload Dedouble
 
End Sub
 
Sub test()
Dim n As Integer
Dim col As Collection
Set col = New Collection
For n = Range("A65536").End(xlUp).Row To 2 Step -1
On Error GoTo suite
 atester = Range("A" & n) & Range("B" & n) & Range("C" & n) & Range("D" & n)
 col.Add atester, CStr(atester)
suite:
If err.Number = 457 Then
Rows(n).Delete
Resume Next
End If
Next n
End Sub