Copie vers autre feuille automatique sans doublons

Le 20/05/2019 à 14:40

Bonjour à tous,

Voila je vous explose mon problème, je souhaite que dans mon tableau Excel certaine ligne soit copier sans doublons.

Exemple en pièce jointe mais je vous décrit la chose.

les lignes de la feuille 2 doivent être copié a la suite de la feuille 3 (sans doublons)

les lignes de la feuille 1 doivent être copié dans la feuille 4 (sans doublons) et seulement si elle ne correspondent pas aux lignes de la feuille 3

Cordialement Arnaud

27exemple.xlsx (16.17 Ko)
Le 21/05/2019 à 09:49

Bonjour Arnaud87, le forum,

Un essai....(CTRL + e pour exécuter la macro)

Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range, rng As Range, i As Integer, dl As Integer

'##################################################################################################
'Copie sans doublons de Feuille2 vers feuille3

Set MonDico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil2")
    For Each c In .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
    Next c
    Sheets("Feuil3").Range("A1").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Set MonDico = Nothing

'##################################################################################################

'Copie sans doublons de Feuille1 vers feuille4

Set MonDico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    For Each c In .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
    Next c
    Sheets("Feuil4").Range("A1").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Set MonDico = Nothing

'##################################################################################################

'suppression données Feuill4 présentes en Feuille3

With Sheets("Feuil4")
 dl = Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To dl

Set rng = .Columns("A:A").Find(What:=Sheets("Feuil3").Range("A" & i), After:=.Range("A1"), SearchOrder:=xlByRows)
     If Not rng Is Nothing Then rng.EntireRow.Delete
     Next i
     i = i + 1
   End With

End Sub
17copie-de-exemple.xlsm (19.43 Ko)

Il y a surement moyen de faire plus simple, , faute de mieux....

Cordialement,

Le 21/05/2019 à 10:32

Bonjour xorsankukai,

Merci pour cette réponse, est il possible de copier les différentes entrées à la suite de ceux déjà existant? (tableau déjà existant avec des données ).

Cordialement

Le 21/05/2019 à 10:49

Re,

Merci pour ton retour...

Merci pour cette réponse, est il possible de copier les différentes entrées à la suite de ceux déjà existant?

A tester....

Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range, rng As Range, i As Integer, dl As Integer, dl2 As Integer, dl3 As Integer

dl2 = Sheets("Feuil3").Range("A" & Rows.Count).End(xlUp).Row + 1
dl3 = Sheets("Feuil4").Range("A" & Rows.Count).End(xlUp).Row + 1

'##################################################################################################
'Copie sans doublons de Feuille2 vers feuille3

Set MonDico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil2")

    For Each c In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
    Next c
    Sheets("Feuil3").Range("A" & dl2).Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Set MonDico = Nothing

'##################################################################################################

'Copie sans doublons de Feuille1 vers feuille4

Set MonDico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    For Each c In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
    Next c
    Sheets("Feuil4").Range("A" & dl3).Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Set MonDico = Nothing

'##################################################################################################

'suppression données Feuill4 présentes en Feuille3

With Sheets("Feuil4")
 dl = .Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To dl

Set rng = .Columns("A:A").Find(What:=Sheets("Feuil3").Range("A" & i), After:=.Range("A1"), SearchOrder:=xlByRows)
     If Not rng Is Nothing Then rng.EntireRow.Delete
     Next i
     i = i + 1
   End With

End Sub
19essai.xlsm (19.80 Ko)

Tu effaces donc les données de Feuil1 et Feuil2 une fois copiées ? Car avec ce code, tu auras des doublons si ce n'est pas le cas,

Cordialement,

Le 21/05/2019 à 11:25

Re,

Je n'efface ni la feuille 1, ni la feuille 2 car celle ci comporte déjà des données de suivi etc...

Cordialement

Le 21/05/2019 à 11:53

Re,

Je m'embrouille un peu....j'ai bossé de nuit, je n'ai pas les idées claires...

Une dernière tentative....

La suppression des doublons s'effectue à l'activation de la feuille....(pour feuille 3 et 4)...

Sub SansDoublonsTrie()

 Dim rng As Range, i As Integer, dl As Integer, dl2 As Integer, dl3 As Integer

  dl2 = Sheets("Feuil3").Range("A" & Rows.Count).End(xlUp).Row + 1
  dl3 = Sheets("Feuil4").Range("A" & Rows.Count).End(xlUp).Row + 1

'##################################################################################################
'Copie données de Feuille2 vers feuille3
With Sheets("Feuil2")
  dl = .Range("A" & Rows.Count).End(xlUp).Row
   .Range("A2:A" & dl).Copy Sheets("Feuil3").Range("A" & dl2)
End With

'##################################################################################################
'Copie données de Feuille1 vers feuille4
With Sheets("Feuil1")
  dl = .Range("A" & Rows.Count).End(xlUp).Row
   .Range("A2:A" & dl).Copy Sheets("Feuil4").Range("A" & dl3)
End With

'##################################################################################################
'suppression données Feuill4 présentes en Feuille3
With Sheets("Feuil4")
 dl = .Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To dl
   Set rng = .Columns("A:A").Find(What:=Sheets("Feuil3").Range("A" & i), After:=.Range("A1"), SearchOrder:=xlByRows)
     If Not rng Is Nothing Then rng.EntireRow.Delete
  Next i
  i = i + 1
End With

Sheets("Feuil1").Activate
End Sub
14exemple4.xlsm (17.75 Ko)

J'espère que c'est OK cette fois,

Cordialement,

Le 21/05/2019 à 14:10

Re,

Désolé mais cela crée des doublons en feuilles 3 et 4, après l'ajout de nouvelles lignes dans les feuilles 1 et 2

Je suis vraiment un nul en VBA. Et je ne sais pas si ma demande est clair.

Encore merci pour ton aide

Cordialement

Le 21/05/2019 à 14:27

Re,

Rassure-toi, ta demande est claire , c'est moi qui ne suis pas performant,

Je n'ai pas les idées claires,

Teste cette version....

Tu rajoutes tes données en Feuille1 et Feuille2 puis tu exécutes la macro .

En sélectionnant Feuille3 où Feuille4, on supprime les doublons.

27copie-de-exemple.xlsm (20.99 Ko)

où

37copie-de-exemple4-3.xlsm (20.90 Ko)

Cordialement,

Le 21/05/2019 à 15:43

Re,

Cela fonctionne sur l'exemple, mais dés que je l’intègre sur mon tableau (env. 300 lignes) celui ci ne fonctionne plus je me retrouve avec des données en X fois, certaines lignes sont écrites X fois dans les feuilles 1 et 2 est ce cela le problème?

Encore merci pour ton aide.

Cordialement

Le 21/05/2019 à 16:37

Re,

celui ci ne fonctionne plus je me retrouve avec des données en X fois, certaines lignes sont écrites X fois dans les feuilles 1 et 2 est ce cela le problème?

Tu n'as pas copié le code qui supprime les doublons dans les feuilles 3 et 4 ?

Private Sub Worksheet_Activate()
  Dim dl As Integer

  dl = Range("A" & Rows.Count).End(xlUp).Row
       Range("A1:A" & dl).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
Spoiler
capture
Spoiler


capture2

Cordialement,

Le 22/05/2019 à 15:10

Bonjour xorsankukai,

Cela fonctionne parfaitement, je n'avais pas vu le code sur les pages 3 et 4.

Encore merci pour ton aide.

Cordialement

Rechercher des sujets similaires à "copie feuille automatique doublons"