Macros pour fusionner et suprimer les doubles

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
 

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

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:

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+
 

skoobi

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

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.
 

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:

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
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:

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
 

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:

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é???)
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
Pour cela tu fais comme ceci (pour n'importe quel code):

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

;)
 
Dernière édition:

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:

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
 

Discussions similaires

Statistiques des forums

Discussions
312 946
Messages
2 093 830
Membres
105 848
dernier inscrit
toooom