Comparer et Deplacer

[sonskriverez]

Bonjour le forum

Je recherche une macro pour comparer les datas de 2 feuilles:

Source 1 colonne A
Source 2 colonne A

Si l'information de la source 2 = source 1 alors :

Copier la ligne entière dans la feuille "destination"
effacer la ligne de la source 1

le fichier d'origne comporte dans les 1500 lignes

Merci de votre aide

 

[Omicron]

Re : Comparer et Deplacer

Bonjour Sonskriverez,

Tu trouveras en pièce jointe un fichier qui doit répondre au problème.

Principe :
Chaque fois que l'on active la feuille "Destination" la liste des Départements existant à la fois dans "Source 1" et "Source 2" est automatiquement réévaluée.

Nb: Si le fichier est trop gros et que les performances ne sont pas assez bonnes. Créer un bouton, déplacer le code de l'évènement Worksheet(Destination)_Activate, dans l'évènement Bouton_Click. Le réévaluation se fera alors à la demande.

Omicron.

 

[Roland_M]

Re : Comparer et Deplacer

bonjour

Salut Omicron ! code très court et efficace !
bien qu'avec Find si la colonne de recherche n'est pas triée j'ai déjà eu des surprises !?

mais notre ami demande la suppression des lignes copiées
de la feuille source 1 !? et là ça se complique avec cette formule !?

voir classeur ci-joint !

EDIT: (pour Omicron) ou alors comme ceci !

DefInt A-Z ' code plus rapide mais avec moins de 32768 lignes !
Private Sub ButtonTransfert_Click()
Dim Departement As Range, Rang As Range
Application.ScreenUpdating = False
Sheets("Destination").UsedRange.Offset(1).Clear
NoDeLigDestin = 1
' boucle dans source 2
For Each Departement In Sheets("Source 2").UsedRange.Columns(1).Offset(1).Cells
 ' recherche le département de la source 2 dans source 1
 Set Rang = Sheets("Source 1").UsedRange.Columns(1).Offset(1).Find(Departement)
 If Not Rang Is Nothing Then
    NoDeLigDestin = NoDeLigDestin + 1 'copie ligne source 1 > destin
    Sheets("Source 1").Rows(Rang.Row).Copy Destination:=Sheets("Destination").Rows(NoDeLigDestin)
    Sheets("Source 1").Rows(Rang.Row).EntireRow.Delete
 End If
Next
Application.ScreenUpdating = True
End Sub

mais avec > Sheets("Destination").UsedRange.Offset(1).Clear
il ne faut pas qu'il clic deux fois vu que les lignes sont supprimées !!!
sinon il perd tout !!!

 

[sonskriverez]

Re : Comparer et Deplacer

Bonjour le forum

Bjr Roland_M,Omicron

Merci pour votre travail, effectivement le code de Roland est trés court et efficace mais il ne supprime pas les lignes de la source 1.

Omicron, je vais tester ton code sur le fichier d'origine mais cela fonctionne trés bien sur l'exemple.

Merci encore

 

[Roland_M]

Re : Comparer et Deplacer

bonjour

je crois que tu n'as pas tout compris !
c'est celui de Omicron qui est court mais ne supprime pas les lignes !
c'est ce que je lui disais dans mon message !
tu as dû confondre quelque chose !

ci-joint
le 1 c'est le mien avec un module !
le 2 c'est celui d'Omicron que j'ai modifié pour effacer !