Discussion :

[kazannova]

Bonsoir

J’ai un classeur Excel avec deux feuilles : OSCAR et JOURNAL

Dans la colonne B2:B6000 de la feuille OSCAR il y a des mots doublons plusieurs fois, parfois en centaines.

Mon souhait est une macro qui permet d’extraire les mots en questions sans leurs doublons dans la colonne B3:B60 de la feuille JOURNAL

C'est-à-dire et par exemple si le mot VENTE existe n fois dans B2:B6000 de la feuille OSCAR il faut que je le trouve copié une seule fois dans la colonne B3:B60 de la feuille JOURNAL.

Merci pour vos aides

[Theze]

Bonjour,

Une piste. Les deux classeurs doivent être ouverts, il te faut adapter les extensions des fichiers dans le code (.xlsx, .xlsm, etc...), ici, Oscar est .xslm et Journal, .xlsx :

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
 
Sub Test()
 
    Dim Dico As Object
    Dim Cle As Variant
    Dim Plage As Range
    Dim Cel As Range
 
    'attention, adapter les extansions des classeurs !
 
    With Workbooks("OSCAR.xlsm").Worksheets("Feuil1"): Set Plage = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With
 
    Set Dico = CreateObject("Scripting.Dictionary")
 
    For Each Cel In Plage: Dico(Cel.Value) = "": Next Cel
 
    Workbooks("JOURNAL.xlsx").Worksheets("Feuil1").Cells(3, 2).Resize(Dico.Count, 1).Value = Application.Transpose(Dico.Keys)
 
End Sub

[Transitoire]

Bonjour, je vous propose une extraction de données sur la feuille Journal depuis Oscar. ci-dessous classeur d'exemple et lien avec le Tutorom de Philippe Tulliez.
https://philippetulliez.developpez.c...dvancedfilter/
TestExtraction.xlsm
Cordialement

[Menhir]

Il suffit de copier l'intégralité de la liste et d'appliquer une méthode RemoveDuplicate sur la zone de destination.
Lire ceci : https://msdn.microsoft.com/fr-fr/lib...3(v=office.15)

[kazannova]

Il suffit de copier l'intégralité de la liste et d'appliquer une méthode RemoveDuplicate sur la zone de destination.
Lire ceci : https://msdn.microsoft.com/fr-fr/lib...3(v=office.15)

Bonjour M. Menhir et merci d'avoir répondu à ma question
la colonne de la feuille dont je veux extraire les données contient plus 6000 lignes et contient aussi des fonctions qui lient mon classeur avec un autre!
si je recopie ça dans la deuxième feuille de classeur pour que je puisse utiliser removeDuplicate, j'aurais besoin de 6000 autres fonctions comme j'aurais besoin de ce classeur pour traiter d'autres dossiers!

[kazannova]

Bonjour, je vous propose une extraction de données sur la feuille Journal depuis Oscar. ci-dessous classeur d'exemple et lien avec le Tutorom de Philippe Tulliez.
https://philippetulliez.developpez.c...dvancedfilter/
TestExtraction.xlsm
Cordialement

Monsieur Transitoire Merci beaucoup
j'ai copié votre macro dans mon classeur mais je ne sais pas pourquoi elle m'a dupliqué un critère aussi elle a supprimé les bordures de tableau
NB: je suis nul en VBA

le code utilisé est:

Code :

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

1
2
3
4
Sub Extraction()
Worksheets("JOURNAL").Activate
Worksheets("OSCAR").Range("B2:B6000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("JOURNAL").Range("B2"), Unique:=True
End Sub

[kazannova]

Bonjour,

Une piste. Les deux classeurs doivent être ouverts, il te faut adapter les extensions des fichiers dans le code (.xlsx, .xlsm, etc...), ici, Oscar est .xslm et Journal, .xlsx :

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
 
Sub Test()
 
    Dim Dico As Object
    Dim Cle As Variant
    Dim Plage As Range
    Dim Cel As Range
 
    'attention, adapter les extansions des classeurs !
 
    With Workbooks("OSCAR.xlsm").Worksheets("Feuil1"): Set Plage = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With
 
    Set Dico = CreateObject("Scripting.Dictionary")
 
    For Each Cel In Plage: Dico(Cel.Value) = "": Next Cel
 
    Workbooks("JOURNAL.xlsx").Worksheets("Feuil1").Cells(3, 2).Resize(Dico.Count, 1).Value = Application.Transpose(Dico.Keys)
 
End Sub

Monsieur Theze

J'ai un seul classeur pas deux, OSCAR et JOURNAL ne sont que deux feuilles de classeur en question

Cordialement

[Transitoire]

Cher Kazannova, mon dossier joint est un exemple, j'ignore tout de votre dossier. Il s'agissait dans mon esprit de vous faire comprendre les possibilités des filtres élaborés. Je vous encourage donc à vous pencher sur le tutorom joint afin de comprendre comment l'adapter aux problèmes inhérents à votre dossier. Après si certains problèmes vous semblent incompréhensibles, il y aura toujours quelqu'un pour vous aider.
Cordialement

Code :

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

1
2
3
Sub test()
Worksheets("JOURNAL").Activate
Worksheets("OSCAR").Range("A1:B2000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("OSCAR").Range("F1:F2"), CopyToRange:=Worksheets("JOURNAL").Range("B1"), Unique:=True

Dans le code ci dessus qui n'est pas le même que celui que vous avez recopié,Range("A1:B2000") est donné à titre d'exemple et doit être ajusté à la réalité de votre document. Idem pour le criteria etc . Unique:=True permet d'éliminer les doublons.
Je vous signale que dans votre recopie, vous avez omis la zone de critère : CriteriaRange:=Worksheets("OSCAR").Range("F1:F2")

[kazannova]

Merci infiniment cher Transitoire

Avec le code suivant ça marche bien

Code :

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

1
2
3
4
Sub Extraction()
Worksheets("JOURNAL").Activate
Worksheets("OSCAR").Range("B1:B6000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("JOURNAL").Range("B1"), Unique:=True
End Sub

Mon soucis est la perte des bordures de tableau. Une possibilité de les garder?



J'ai bricolé par l'enregistrement d'une macro pour remettre les bordures effacées :-) mais c'est un travail de plus!

[Transitoire]

Mon soucis est la perte des bordures de tableau. Une possibilité de les garder
J'ai bricolé par l'enregistrement d'une macro pour remettre les bordures effacées :-) mais c'est un travail de plus!

Non, ça n'est pas un travail de plus, vous pouvez mettre votre enregistrement des bordures dans une autre macro ex:

Code :

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

1
2
3
4
5
6
Sub Bordures()
Application.ScreenUpdating = False   'permet d'éviter le rafraichissement de l'écran jusqu'a la fin de la procédure.
..........
..........     'code de l'enregistreur de macro
Application.ScreenUpdating = true  'Rafraichissement de l'écran.
end Sub

Et vous rajoutez dans le code du post plus haut:

Code :

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

1
2
3
4
5
6
 
Sub test()
Worksheets("JOURNAL").Activate
Worksheets("OSCAR").Range("A1:B2000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("OSCAR").Range("F1:F2"), CopyToRange:=Worksheets("JOURNAL").Range("B1"), Unique:=True
Bordures
End Sub'  La procédure test après avoir extrait les données, va mettre en forme les bordures par l'appel de la procédure "Bordures"

'

Attention, je n'ai pas pu vérifier le bon fonctionnement de la macro
Cordialement

[kazannova]

Je l'ai fais et ça marche à merveille
Un très grand merci Cher Transitoire