J'ai une feuille "fichier client" avec les colonnes suivantes :
A:N° Salon - B:N° Client - C:Civilité - D:Nom Client - E:Prénom Client -
F:Adresse 1...
Je souhaiterai extraire les doublons dans la feuille "fichier client à
rectifier" et les supprimer de la feuille "fichier client" automatiquement.
Voici la macro :
Sub SuppressionClients()
Dim Plage As Range, c As Range, Ligne As Long
Range("J:K").Insert
Ligne = 1
Set Plage = Range("D2", Range("D65536").End(xlUp))
For Each c In Plage
c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value
Next c
For Each c In Plage
c.Offset(0, 7).Value = _
WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6))
Next c
Range("k:k").Copy
Range("k:k").PasteSpecial xlPasteValues
For Each c In Plage
If c.Offset(0, 7).Value > 1 Then
Range("A" & c.Row & ":I" & c.Row).Copy _
Sheets("Fichier client à rectifier").Range("A" & Ligne)
Ligne = Ligne + 1
c.EntireRow.Delete
End If
Next c
Range("J:K").Delete
End Sub
Cependant, il ne m'extrait q'un seul des doublons pour certaines lignes et
les 2 pour d'autres.... Je n'y comprend plus rien.
J'ai joins mon fichier pour exemple.
http://cjoint.com/?cex6Vw7kHI
Bonsoir, Une méthode inspirée de celle proposée par AV me semblerait préférable, je suggèrerais même qu'en utilisant une formule et un filtre simple on obtient la liste des clients à vérifier. Toutefois pour respecter ton souhait voici (selon le code que tu proposes) même là aussi il y aurait probablement autre méthode
Private Sub CommandButton1_Click()
Dim Plage As Range, c As Range, Ligne As Long, d As Long Application.ScreenUpdating = False Range("J:K").Insert Ligne = 1 Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom For Each c In Plage c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne J For Each c In Plage c.Offset(0, 7).Value = _ WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6)) Next c
For d = Range("D65536").End(xlUp).Row To 2 Step -1 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Rows(d).Delete End If Next d
Range("J:K").Delete Application.ScreenUpdating = True MsgBox "Extraction des doublons de noms terminée !"
End Sub
"Nadyajah" a écrit dans le message de news:
Re,
J'ai supprimée la ligne "Row(x).Delete" pour voir si cela fonctionne mais il ne m'extrait rien....
Voici le fichier joint http://cjoint.com/data/cgwLTAtCoz.htm
Bonsoir,
Une méthode inspirée de celle proposée par AV me semblerait préférable,
je suggèrerais même qu'en utilisant une formule et un filtre simple on
obtient la liste des clients à vérifier.
Toutefois pour respecter ton souhait voici (selon le code que tu proposes)
même là aussi il y aurait probablement autre méthode
Private Sub CommandButton1_Click()
Dim Plage As Range, c As Range, Ligne As Long, d As Long
Application.ScreenUpdating = False
Range("J:K").Insert
Ligne = 1
Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom
For Each c In Plage
c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value
Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne
J
For Each c In Plage
c.Offset(0, 7).Value = _
WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6))
Next c
For d = Range("D65536").End(xlUp).Row To 2 Step -1
If Cells(d, 4).Offset(0, 7).Value > 1 Then
Range("A" & d & ":I" & d).Copy _
Sheets("Fichier client à rectifier").Range("A" & Ligne)
Ligne = Ligne + 1
Rows(d).Delete
End If
Next d
Range("J:K").Delete
Application.ScreenUpdating = True
MsgBox "Extraction des doublons de noms terminée !"
End Sub
"Nadyajah" <Nadyajah@discussions.microsoft.com> a écrit dans le message de
news: 94C8D7D2-F9D9-421D-897A-5D5B309C6A86@microsoft.com...
Re,
J'ai supprimée la ligne "Row(x).Delete" pour voir si cela fonctionne mais
il
ne m'extrait rien....
Voici le fichier joint
http://cjoint.com/data/cgwLTAtCoz.htm
Bonsoir, Une méthode inspirée de celle proposée par AV me semblerait préférable, je suggèrerais même qu'en utilisant une formule et un filtre simple on obtient la liste des clients à vérifier. Toutefois pour respecter ton souhait voici (selon le code que tu proposes) même là aussi il y aurait probablement autre méthode
Private Sub CommandButton1_Click()
Dim Plage As Range, c As Range, Ligne As Long, d As Long Application.ScreenUpdating = False Range("J:K").Insert Ligne = 1 Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom For Each c In Plage c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne J For Each c In Plage c.Offset(0, 7).Value = _ WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6)) Next c
For d = Range("D65536").End(xlUp).Row To 2 Step -1 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Rows(d).Delete End If Next d
Range("J:K").Delete Application.ScreenUpdating = True MsgBox "Extraction des doublons de noms terminée !"
End Sub
"Nadyajah" a écrit dans le message de news:
Re,
J'ai supprimée la ligne "Row(x).Delete" pour voir si cela fonctionne mais il ne m'extrait rien....
Voici le fichier joint http://cjoint.com/data/cgwLTAtCoz.htm
JLuc
*Bonjour Nadyajah*, Il y avait une petite erreur qui c'etait glissee, Row --> Rows Voila la boucle qui fait cette copy comme tu le veux :
For d = Range("D65536").End(xlUp).Row To 2 Step -1 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Destination:=Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Rows(d).Delete End If Next d
Bonsoir, Alors j'ai remplacé le c par "x" mais il s'arrête sur la ligne : Row(x).Delete et me dit "sub ou fonction non définie"
?????
Revoila ma macro en globalité
Sub SuppressionClients()
Dim Plage As Range, c As Range, Ligne As Long, d As Long Range("J:K").Insert Ligne = 1 Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom For Each c In Plage c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne J For Each c In Plage c.Offset(0, 7).Value = _ WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6)) Next c
For d = Range("D65536").End(xlUp).Row To 2 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Row(d).Delete End If Next d
Range("J:K").Delete
MsgBox "Extraction des doublons de noms terminée !" End Sub
-- ____ ( O | O ) -- _oooO_ JLuc _Oooo_
O-O
*Bonjour Nadyajah*,
Il y avait une petite erreur qui c'etait glissee, Row --> Rows
Voila la boucle qui fait cette copy comme tu le veux :
For d = Range("D65536").End(xlUp).Row To 2 Step -1
If Cells(d, 4).Offset(0, 7).Value > 1 Then
Range("A" & d & ":I" & d).Copy _
Destination:=Sheets("Fichier client à rectifier").Range("A" &
Ligne)
Ligne = Ligne + 1
Rows(d).Delete
End If
Next d
Bonsoir,
Alors j'ai remplacé le c par "x" mais il s'arrête sur la ligne :
Row(x).Delete
et me dit "sub ou fonction non définie"
?????
Revoila ma macro en globalité
Sub SuppressionClients()
Dim Plage As Range, c As Range, Ligne As Long, d As Long
Range("J:K").Insert
Ligne = 1
Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom
For Each c In Plage
c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value
Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne J
For Each c In Plage
c.Offset(0, 7).Value = _
WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6))
Next c
For d = Range("D65536").End(xlUp).Row To 2
If Cells(d, 4).Offset(0, 7).Value > 1 Then
Range("A" & d & ":I" & d).Copy _
Sheets("Fichier client à rectifier").Range("A" & Ligne)
Ligne = Ligne + 1
Row(d).Delete
End If
Next d
Range("J:K").Delete
MsgBox "Extraction des doublons de noms terminée !"
End Sub
*Bonjour Nadyajah*, Il y avait une petite erreur qui c'etait glissee, Row --> Rows Voila la boucle qui fait cette copy comme tu le veux :
For d = Range("D65536").End(xlUp).Row To 2 Step -1 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Destination:=Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Rows(d).Delete End If Next d
Bonsoir, Alors j'ai remplacé le c par "x" mais il s'arrête sur la ligne : Row(x).Delete et me dit "sub ou fonction non définie"
?????
Revoila ma macro en globalité
Sub SuppressionClients()
Dim Plage As Range, c As Range, Ligne As Long, d As Long Range("J:K").Insert Ligne = 1 Set Plage = Range("D2", Range("D65536").End(xlUp))
'insère dans la colonne J la valeur Nom&Prénom For Each c In Plage c.Offset(0, 6).Value = c.Value & c.Offset(0, 1).Value Next c
'insère dans la colonne K le nombre de doublons trouvés dans la colonne J For Each c In Plage c.Offset(0, 7).Value = _ WorksheetFunction.CountIf(Plage.Offset(0, 6), c.Offset(0, 6)) Next c
For d = Range("D65536").End(xlUp).Row To 2 If Cells(d, 4).Offset(0, 7).Value > 1 Then Range("A" & d & ":I" & d).Copy _ Sheets("Fichier client à rectifier").Range("A" & Ligne) Ligne = Ligne + 1 Row(d).Delete End If Next d
Range("J:K").Delete
MsgBox "Extraction des doublons de noms terminée !" End Sub
-- ____ ( O | O ) -- _oooO_ JLuc _Oooo_
O-O
AV
Cependant, ta macro n'extrait qu'un seul des doublons | alors que je souhaiterais extraire les 2.
Tu es victime d'un micro-climat ....
AV
Cependant, ta macro n'extrait qu'un seul des doublons
| alors que je souhaiterais extraire les 2.
