Macros pour fusionner et suprimer les doubles

V

vince345

XLDnaute Nouveau
Bonjour je suis nouveau et je voudrais un peu d'aide en VBA pour excel .
Voilà mon problème.

Je voudrais faire une macro pour excel qui fusionne deux colones en une seule et qu'apres ou pendant la fusion supprime les mots ou chiffres en double

EX:

colone 1 colone 2
coucou coucou
bonjour aurevoir
hey hey

retourne

coucou
bonjour
aurevoir
hey


Merci pour votre aide :)
J'espère avoir été asser précis dans mes mots
 
Trier par date Trier par votes
skoobi

skoobi

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Bonjour vince345, bienvenue sur XLD,

En PJ une proposition, voir si ça te conviens.
 

Pièces jointes

  • Classeur3.zip
    6.4 KB · Affichages: 32
  • Classeur3.zip
    6.4 KB · Affichages: 33
  • Classeur3.zip
    6.4 KB · Affichages: 37
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Alors là, Bravo, Skoobi

vu le "Urgent!!!" dans le titre, je m'attendais à ce qu'il n'y ait pas de réponse. Franchement, ta réponse est SENSAS!

je viens juste d'écrire une macro qui réalise la synthèse de 100 fichiers départementaux, et je me demandais comment utiliser ton
Code: 
Set trouve = Columns(1).Find(cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
dans ma macro,
aurais-tu l'obligeance de m'éclairer sur ce point?
(ma macro n'est pas du tout optimisée, mais elle fonctionne...)

Il s'agit de recopier les cellules B3 à K3 de chacun des 100 classeurs départements dans mon classeur récap
qui comporte la liste des dépatements comme suit :
DEPT 01 en A3
DEPT 02 en A4 etc...
DEPT 2A en A22
DEPT 2B en A23
DEPT 21 en A24 etc...
DEPT 971 en A99
puis DEPT 972 DEPT 973 DEPT 974 respectivement en A100 A101 A102
et à la suite du département on recopie les cellules B3 à K3 de chacun des 100 classeurs
mes 100 classeurs sont nommée DEPT 01.xls à DEPT 974.xls,
donc ma colonne A reprend les noms de ces classeurs.
Code: 
Option Explicit
Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 07/07/2008 par C@thy
'
Dim zone1
Dim Chemin$, cl$, Dept$, Nom$
Dim Fichiers As Object, Classeur As Object
Dim NbFichiers As Integer
Dim Tableau() As String
Dim X As Integer, Lig As Integer
Dim WsS As Worksheet, WsD As Worksheet 'Source et Destination
Dim ListeClasseurs As New Collection
Dim Fichier As Workbook
Dim cellul As String
Chemin = ThisWorkbook.Path
  cl = Dir(ThisWorkbook.Path & "\*.xls")
 
Application.ScreenUpdating = False
Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
 For Each Classeur In Fichiers
            If Classeur.Name <> ThisWorkbook.Name Then
            If Right(Classeur.Name, 3) = "xls" And Left(Classeur.Name, 5) = "DEPT " Then
                ListeClasseurs.Add Classeur.Name
                NbFichiers = NbFichiers + 1
                ReDim Preserve Tableau(1 To NbFichiers)
                Tableau(NbFichiers) = cl
                cl = Dir()
            End If
         End If
Next
Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
For X = 1 To NbFichiers 'boucles sur les classeurs
Chemin = ThisWorkbook.Path & "\" & ListeClasseurs(X)
Set WsD = ThisWorkbook.Worksheets("FRANCE")
      Set Fichier = Workbooks.Open(Chemin)
      Set WsS = Fichier.Worksheets(1)
 Nom = ListeClasseurs(X)
 Dept = Mid(Nom, 1, 7)
 If Dept = "DEPT 97" Then Dept = Mid(Nom, 1, 8)
 
  zone1 = WsS.Range("B3:K3")
  Windows("Copie de Copie de Tableau Dept TEST.xls").Activate
  Range("A3").Select
 
    Cells.Find(What:=Dept, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Lig = ActiveCell.Row
 
    WsS.Range("B3:K3").Copy WsD.Range("B" & Lig)
    Fichier.Close
Next
End Sub

j'ai essayé, mais ça ne fonctionne pas en déclarant la variable trouve en type String. En plus il faut que je mette les valeurs sur la bonne ligne et pas la dernière!
Code: 
For Each cellule In Range([A3], [A3].End(xlDown))
    Set trouve = Columns(1).Find(cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
   If Not trouve Is Nothing Then [A3].Offset(0, 1).Value = zone1
Next
évidemment ç'est pas bon!
Si tu pouvais m'aider à optimiser mon code très lourd, ce serait super sympa.
(je pense qu'il n'y a pas que ce passage qui est très lourd!!!)

En te remerciant mille fois,

Biz

C@thy
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Bonjour,
Une solution en utilisant une collection.
Données en colonnes A et B, fusionnées en C.

Code: 
Sub Fusion()
Dim test1 As Long, test2 As Long, i As Long, c As New Collection
On Error Resume Next
For i = 1 To Range("A65536").End(xlUp).Row
test1 = 0
test1 = Application.Match(Cells(i, 1), Range(Cells(1, 1), Cells(i - 1, 1)), 0)
test2 = 0
test2 = Application.Match(Cells(i, 1), Range(Cells(1, 2), Cells(i - 1, 2)), 0)
If test1 + test2 = 0 Then c.Add Cells(i, 1).Value
test1 = 0
test1 = Application.Match(Cells(i, 2), Range(Cells(1, 1), Cells(i, 1)), 0)
test2 = 0
test2 = Application.Match(Cells(i, 2), Range(Cells(1, 2), Cells(i - 1, 2)), 0)
If test1 + test2 = 0 Then c.Add Cells(i, 2).Value
Next
For i = 1 To c.Count
Range("C" & i) = c(i)
Next
End Sub

A+
 
Vote positif 0 Vote négatif
skoobi

skoobi

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

C@thy à dit:
Alors là, Bravo, Skoobi

vu le "Urgent!!!" dans le titre, je m'attendais à ce qu'il n'y ait pas de réponse. Franchement, ta réponse est SENSAS!

je viens juste d'écrire une macro qui réalise la synthèse de 100 fichiers départementaux, et je me demandais comment utiliser ton
Code: 
Set trouve = Columns(1).Find(cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
dans ma macro,
aurais-tu l'obligeance de m'éclairer sur ce point?
(ma macro n'est pas du tout optimisée, mais elle fonctionne...)

Il s'agit de recopier les cellules B3 à K3 de chacun des 100 classeurs départements dans mon classeur récap
qui comporte la liste des dépatements comme suit :
DEPT 01 en A3
DEPT 02 en A4 etc...
DEPT 2A en A22
DEPT 2B en A23
DEPT 21 en A24 etc...
DEPT 971 en A99
puis DEPT 972 DEPT 973 DEPT 974 respectivement en A100 A101 A102
et à la suite du département on recopie les cellules B3 à K3 de chacun des 100 classeurs
mes 100 classeurs sont nommée DEPT 01.xls à DEPT 974.xls,
donc ma colonne A reprend les noms de ces classeurs.
Code: 
Option Explicit
Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 07/07/2008 par C@thy
'
Dim zone1
Dim Chemin$, cl$, Dept$, Nom$
Dim Fichiers As Object, Classeur As Object
Dim NbFichiers As Integer
Dim Tableau() As String
Dim X As Integer, Lig As Integer
Dim WsS As Worksheet, WsD As Worksheet 'Source et Destination
Dim ListeClasseurs As New Collection
Dim Fichier As Workbook
Dim cellul As String
Chemin = ThisWorkbook.Path
  cl = Dir(ThisWorkbook.Path & "\*.xls")
 
Application.ScreenUpdating = False
Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
 For Each Classeur In Fichiers
            If Classeur.Name <> ThisWorkbook.Name Then
            If Right(Classeur.Name, 3) = "xls" And Left(Classeur.Name, 5) = "DEPT " Then
                ListeClasseurs.Add Classeur.Name
                NbFichiers = NbFichiers + 1
                ReDim Preserve Tableau(1 To NbFichiers)
                Tableau(NbFichiers) = cl
                cl = Dir()
            End If
         End If
Next
Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
For X = 1 To NbFichiers 'boucles sur les classeurs
Chemin = ThisWorkbook.Path & "\" & ListeClasseurs(X)
Set WsD = ThisWorkbook.Worksheets("FRANCE")
      Set Fichier = Workbooks.Open(Chemin)
      Set WsS = Fichier.Worksheets(1)
 Nom = ListeClasseurs(X)
 Dept = Mid(Nom, 1, 7)
 If Dept = "DEPT 97" Then Dept = Mid(Nom, 1, 8)
 
  zone1 = WsS.Range("B3:K3")
  Windows("Copie de Copie de Tableau Dept TEST.xls").Activate
  Range("A3").Select
 
    Cells.Find(What:=Dept, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Lig = ActiveCell.Row
 
    WsS.Range("B3:K3").Copy WsD.Range("B" & Lig)
    Fichier.Close
Next
End Sub
j'ai essayé, mais ça ne fonctionne pas en déclarant la variable trouve en type String. En plus il faut que je mette les valeurs sur la bonne ligne et pas la dernière!
Code: 
For Each cellule In Range([A3], [A3].End(xlDown))
    Set trouve = Columns(1).Find(cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
   If Not trouve Is Nothing Then [A3].Offset(0, 1).Value = zone1
Next
évidemment ç'est pas bon!
Si tu pouvais m'aider à optimiser mon code très lourd, ce serait super sympa.
(je pense qu'il n'y a pas que ce passage qui est très lourd!!!)

En te remerciant mille fois,

Biz

C@thy
Cliquez pour agrandir...

Bonjour Cathy,

Vu que tu manipules 100 fichiers:eek:, il faut absolument éviter les .Select, c'est ce que j'ai fais car ça ralentie le code;).
Dis nous si c'est un peu plus rapide.
Sinon, je vois pas autre chose qui l'alourdie.
Pour ce qui est de:
Code: 
Set trouve = Columns(1).Find(cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
.Find renvoie un Range, c'est pourquoi il faut déclarer la variable en tant qu'objet:
Code: 
Dim trouve As Range
Le "Set" devant est nécessaire vu que c'est un objet.
J'ai mis (comme tu pourras le remarquer) des commentaires.
Voici le code que je n'ai pas testé (j'avais pas 100 fichiers sous la main :D) mais ça devrait marcher (si j'ai bien compris):
Code: 
Option Explicit
Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 07/07/2008 par C@thy
'
  Dim zone1 As Range, trouve As Range  'modifié par skoobi
  Dim Chemin$, cl$, Dept$, Nom$
  Dim Fichiers As Object, Classeur As Object
  Dim NbFichiers As Integer
  Dim Tableau() As String
  Dim X As Integer, Lig As Integer
  Dim WsS As Worksheet, WsD As Worksheet  'Source et Destination
  Dim ListeClasseurs As New Collection
  Dim Fichier As Workbook
  Chemin = ThisWorkbook.Path
  cl = Dir(ThisWorkbook.Path & "\*.xls")

  Application.ScreenUpdating = False
  Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
  For Each Classeur In Fichiers
    If Classeur.Name <> ThisWorkbook.Name Then
      If Right(Classeur.Name, 3) = "xls" And Left(Classeur.Name, 5) = "DEPT " Then
        ListeClasseurs.Add Classeur.Name
        NbFichiers = NbFichiers + 1
        ReDim Preserve Tableau(1 To NbFichiers)
        Tableau(NbFichiers) = cl
        cl = Dir()
      End If
    End If
  Next
  'mis en commentaire par skoobi, inutile
  'Set Fichiers = CreateObject("Scripting.FileSystemObject").getfolder(Chemin).Files
  Set WsD = ThisWorkbook.Worksheets("FRANCE") 'déplacé par skoobi
  For X = 1 To NbFichiers  'boucles sur les classeurs
    Chemin = ThisWorkbook.Path & "\" & ListeClasseurs(X)
    Set Fichier = Workbooks.Open(Chemin)
    Set WsS = Fichier.Worksheets(1)
    Nom = ListeClasseurs(X)
    Dept = Mid(Nom, 1, 7)
    If Dept = "DEPT 97" Then Dept = Mid(Nom, 1, 8)

    Set zone1 = WsS.Range("B3:K3")  'modifié par skoobi
    'mis en commentaire par skoobi, inutile
    '  Windows("Copie de Copie de Tableau Dept TEST.xls").Activate
    '  Range("A3").Select

    'modifié par skoobi:
    Set trouve = WsD.Columns(1).Find(What:=Dept, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False)
    'mis en commentaire par skoobi, inutile
    '    Lig = ActiveCell.Row
    zone1.Copy trouve.Offset(0, 1)  'modifié par skoobi
    Fichier.Close
  Next
End Sub

Bon test et bonne soirée.
Bises.
 
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Trop génial, skoobi!

Tu sais, je suis une fille très select! niark!:p

Oui, tout ça ça alourdit et 100 classeurs c'est pas rien!!!

Merci beaucoup et bonne soirée.

C@thy
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Bonsoir à tous


•—› C@thy:

Comme Skoobi (bonsoir ;) )
Dis nous si c'est un peu plus rapide
Cliquez pour agrandir...
j'aimerai moi aussi connaître le gain de temps ,stp.


•—› Skoobi

 Oui, ti=out --> Oui, tout ça

pour pour Thierry Lhermitte:
Oui,tout cela

non ?
 
Dernière édition:
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Merci pour l'explication sur le type de la variable, j'essaierai de plus faire la bêtise!!!

Euh... si j'osais, Skoobi,
j'ai la création de mes 100 fichiers qui a sans doute aussi besoin d'un régime allégé...

Dis-moi juste ce que tu en penses... (est-ce que le for... next est le plus approprié???)

Code: 
Sub CreerTableaux()
Dim i%
Dim NouveauF$, Nom$
Dim WbkD As Workbook, WsD As Worksheet
Dim Chem$
  Chem = ThisWorkbook.Path & "\"
  Set WbkD = ThisWorkbook
  With Application
    .ScreenUpdating = False
  End With
  Set WsD = ThisWorkbook.Worksheets(2)
For i = 2 To 101
      'copie dans un nouveau fichier
      Range("B1") = WsD.Cells(i, 1)
      NouveauF = "DEPT" & WsD.Cells(i, 1)
      Nom = Chem & NouveauF & ".xls"
      ActiveWorkbook.SaveAs Filename:=Nom
Next i
  
  With Application
    .Calculation = xlAutomatic 'pour le recherchev
    .ScreenUpdating = True
  End With
 
End Sub

je précise que j'ai en feuille 2 colonne A les numéros des départements avec un espace devant, de espace01 à espace974 en passant par espace2A et 2B bien sûr! (Et en colonne B le libellé du département et en C de la région pour faire un RECHERCHEV).

Mille mercis et Bizous

C@thy
 
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Oui, Staple1600, et Skoobi je confirme, c'est plus rapide!

De combien, c'est pas facile à dire j'ai fait un test sur 3 départements, et c'est immédiat!
Reste à remplir les 100 classeurs pour tester en grandeur réelle.

J'ai corrigé la fotte! (ti=out)
Bip Bip!

C@thy
 
Dernière édition:
Vote positif 0 Vote négatif
skoobi

skoobi

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Re,

j'ai la création de mes 100 fichiers qui a sans doute aussi besoin d'un régime allégé...

Dis-moi juste ce que tu en penses... (est-ce que le for... next est le plus approprié???)
Cliquez pour agrandir...
Ce qui va influer ici sur le temps d'exécution c'est à mon avis la sauvegarde, chose que tu ne peux pas raccourcir, même en ajoutant bipbip dans le code :D.
Par contre, si c'était 100 feuilles à créer dans le même fichier...., mais tu as sans doute des raisons de créer d'autres fichiers.
De combien, c'est pas facile à dire
Cliquez pour agrandir...
Pour cela tu fais comme ceci (pour n'importe quel code):

Sub macro()
t = Timer
...
.......
..........
.............
MsgBox Timer - t
End Sub

;)
 
Dernière édition:
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Urgent !!!! Macros pour fusionner et suprimer les doubles

Merci Skoobi,

donc finalement mon code n'est pas si mal que ça!... je progresse!!!:D

En fait chaque délégué départemental doit remplir son classeur, on ne va pas envoyer 100 feuilles à chacun pour qu'il n'en remplisse qu'une!!!
(Dommage!)

Quant au temps de traitement : 0,75 des 2 côtés! C'est bizarre car j'ai vraiment l'impression que la tienne est + rapide!! On verra ça quand les 100 classeurs seront remplis.

Merci beaucoup pour ton aide,

Biz et bonne journée

C@thy
 
Dernière édition:
Vote positif 0 Vote négatif
C@thy

C@thy

XLDnaute Barbatruc
Re : Macros pour fusionner et suprimer les doubles

Ah ben ça, c'est vraiment super gentil!!!

(Euh, j'avais peur que tu me grondes, j'ai profité d'un post pour poser ma question au lieu de faire un nouveau fil! Je suis pardonnée?)

Bises, Pascal

C@thy
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question
XL 2019 Lier deux fichiers pour traitements de données sur Excel et ou google sheets
Réponses
0
Affichages
339
nhaeliko
N
A
Bonjour à toutes et tous je peux aider hors VBA pour les logiciels SuperNova et ZoomText (Agrandisseurs) + FUSION JAWS et NVDA (Lecteurs d'écran)
Réponses
1
Affichages
537
dysorthographie
dysorthographie
S
  • Question
XL 2019 Aide Excel, fusionner les doublons de deux tableaux et ajouter les colonnes
Réponses
0
Affichages
1 K
SO6
S
oguruma
POWERQUERY :: Combinaisons (Table.Combine) de dossiers contenant des fichiers .CSV ou des fichiers Excel - V2
Réponses
0
Affichages
368
oguruma
oguruma
K
  • Question
XL 2019 Extraction données avec filtre d'un fichier .txt sur Excel & créer nouveau fichier .txt
Réponses
1
Affichages
2 K
Hasco
Hasco
L
  • Question
XL 2016 Macro et suppressions de lignes
Réponses
9
Affichages
680
fanfan38
fanfan38
laurent950
  • Question
XL 2013 Les Fonctions personnalisé avec Aide à la saisie et Aide boite de dialogue
Réponses
0
Affichages
2 K
laurent950
laurent950
F
  • Question
Autres VBA Fusionner puis envoyer Word avec Outlook
Réponses
0
Affichages
898
FOUQUET Yves
F
M
  • Question
Problème de référence formule et graphique lors de copie de feuilles excel pour réinitialiser données
Réponses
4
Affichages
1 K
mathi22
M
D
  • Question
XL 2019 Macro pour imprimer et enregistrer
Réponses
0
Affichages
1 K
Dim.Reichart
D

Membres actuellement en ligne

1 membres et 41 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
313 344
Messages
2 097 337
Membres
106 916
dernier inscrit
Soltani mohamed