Comparaison de 2 feuilles pour générer une MAJ

  • Initiateur de la discussion Initiateur de la discussion muzan97
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

M

muzan97

Guest
Bonjour,
Voici mon problème:
J'ai 2 feuilles Excel contenant chacune une colonne.
La 2de feuille est une mise à jour de la 1ère (certaines cellules ont disparues, d'autres ont été créées).
Je voudrais en générer une 3ème qui ne contiennent que les cellules nouvelles.
J'ai joint un exemple avec le résultat souhaité en feuille 3.

Je précise que les feuilles exemples ne contiennent que quelques lignes alors que les feuilles sur lesquelles je travaille font plus de 40000 lignes
.
Merci d'avance pour votre aide,

M.
 

Pièces jointes

Dernière modification par un modérateur:
Re : Comparaison de 2 feuilles pour générer une MAJ

Bonsoir,

Bonsoir, Catrice

Je m'étais également posé la même question, et j'ai considéré qu'il ne prenait que les 28 premiers caractères de chaque cellule...

La réponse se copie en colonne B de F3

Le code :

Code:
Sub extract()
Dim Uniques1 As Object, Uniques2 As Object, Cel As Range
Set Uniques1 = CreateObject("Scripting.Dictionary")
Set Uniques2 = CreateObject("Scripting.Dictionary")
With Sheets("F1")
    For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
        If Not Uniques1.Exists(Cel) Then Uniques1.Add Cel, Cel
    Next Cel
End With
With Sheets("F2")
    For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
        If Not Uniques2.Exists(Cel) Then Uniques2.Add Cel, Cel
    Next Cel
End With
For Each it2 In Uniques2.items
    For Each it1 In Uniques1.items
        If Left(it1, 28) = Left(it2, 28) Then Uniques2.Remove (it2): Exit For
    Next it1
Next it2
With Sheets("F3")
    .Columns(2).ClearContents
    .[B1].Resize(Uniques2.Count, 1).Value = Application.Transpose(Uniques2.items)
End With
End Sub

le fichier :
 

Pièces jointes

Re : Comparaison de 2 feuilles pour générer une MAJ

Re,

Ci-joint une version qui traite le 1er "champ" de 28 caracteres.

Sub Test()
Sheets("Solution").Cells.Clear
For Each X In Sheets("F2").Range("A1:" & Sheets("F2").Range("A65536").End(xlUp).Address)
Set c = Sheets("F1").Columns("A:A").Find(Left(X, 28), LookAt:=xlPart)
If c Is Nothing Then X.Copy (Sheets("Solution").Range("A65536").End(xlUp).Offset(1, 0))
Next
Sheets("Solution").Range("A1").EntireRow.Delete
End Sub
 

Pièces jointes

Re : Comparaison de 2 feuilles pour générer une MAJ

Merci les amis!

En effet, je n'avais pas vu que certaines lignes étaient modifiées.

J'ai tenté la dernière solution mais malheureusement, vu le nombre élevé de lignes, mon ordi ne suit pas.
Je l'ai laissé tourner une heure et excel ne répondait toujours pas.

Je réessayerai avec moins de données...
 
Re : Comparaison de 2 feuilles pour générer une MAJ

Bonjour muzan97,
Catrice 🙂,
Hub 🙂,

Je réessayerai avec moins de données...
Si tu as près de 40000 lignes à traiter, en reprenant le code de Catrice:
Code:
Sub Test()
Dim Plage As Range
Sheets("Solution").Cells.Clear
With Sheets("F2")
  For Each X In .Range("A1:" & .Range("A65536").End(xlUp).Address)
      Set c = Sheets("F1").Columns("A:A").Find(Left(X, 28), LookAt:=xlPart)
      If c Is Nothing Then
        If Plage Is Nothing Then
          Set Plage = .Range("A1")
        Else: Set Plage = Union(Plage, X)
        End If
      End If
  Next
End With
Plage.Copy Sheets("Solution").Range("A1")
End Sub

Bonne fêtes à vous.
 
Re : Comparaison de 2 feuilles pour générer une MAJ

Bonjour à tous et joyeux Noel,

La solution de Skoobi est super.

Mais je crois qu'il faut modifier une ligne :

If Plage Is Nothing Then
Set Plage = .Range("A1")
Else: Set Plage = Union(Plage, X)

en

If Plage Is Nothing Then
Set Plage = X
Else: Set Plage = Union(Plage, X)

D'apres un petit test, je gagne 1/4 à 1/3 du temps déexecution
 
Dernière édition:
Re : Comparaison de 2 feuilles pour générer une MAJ

Bonsoir,

Bonsoir, Catrice et Skoobi

mon code un peu modifié...

PS, testé sur 55552 lignes en feuille("F1"),
59574 lignes en feuille("F2"),
avec un résultat de 470 lignes en 2 secondes et des broutilles, avec mon code, et arrêt du code de ton code, Skoobi, au bout d'un quart d'heure (le ventilo s'emballait.......😀)

Code:
Sub extract()
Dim Uniques2 As Object, Cel As Range
Set Uniques2 = CreateObject("Scripting.Dictionary")
With Sheets("F2")
    For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
        If Not Uniques2.Exists(Left(Cel, 28)) Then Uniques2.Add Left(Cel, 28), Cel
    Next Cel
End With
With Sheets("F1")
    For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
        If Uniques2.Exists(Left(Cel, 28)) Then Uniques2.Remove (Left(Cel, 28))
    Next Cel
End With
With Sheets("F3")
    .Columns(2).ClearContents
    .[B1].Resize(Uniques2.Count, 1).Value = Application.Transpose(Uniques2.items)
End With
End Sub

Joyeuses Fêtes à tous....
 
Re : Comparaison de 2 feuilles pour générer une MAJ

Re,

arrêt du code de ton code, Skoobi, au bout d'un quart d'heure (le ventilo s'emballait.......😀)
Arff, désolé, j'avoue que je n'ai pas testé sur une longue liste, mais je ne pensais pas que cela serait si long!
J'espère en tout cas que ton ventilo n'a pas pris un cout de vieux, au cas où, tu sauras ce que tu dois commander au Père Noël l'année prochaine 😀😛.
Au plaisir 🙂.
Edit: J'ai aussi fais un test de mon code sur ~57000 lignes et ça n'a pas pris plus de 7s....(y a pas que le ventilo qui s'embale chez-toi bhbh 😀)
 
Dernière édition:
Re : Comparaison de 2 feuilles pour générer une MAJ

Re-,

C'est "Balo", je n'ai pas enregistré, le fichier Xl, avec tous mes tests.....

Si Muzan97 pouvait mettre son fichier, avec 2 colonnes par feuilles, mais avec ses 40 000 lignes, et quelques......

Si cela ne passe pas sur ce site, regarder vers ICI

Bonne soirée
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

Réponses
3
Affichages
882
L
Réponses
12
Affichages
1 K
LeSaintKebab
L
Retour