Comparaison

G

guytares

XLDnaute Nouveau
Bonjour je cherche à comparer deux listes en A et C d'une feuille exel de 200000 lignes avec si valeur de C est dans A alors copier valeur écrite en B dans D avec mais sans application transpose qui limite le résultat à 65000. Merci d'avance
 

Pièces jointes

  • exemple.xlsx
    9 KB · Affichages: 33
  • exemple.xlsx
    9 KB · Affichages: 42
  • exemple.xlsx
    9 KB · Affichages: 42
Trier par date Trier par votes
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Comparaison

Bonjour guytares

A tester:
Code: 
Sub report()
acopier = "nok"
tablo = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row)
  For m = LBound(tablo, 1) To Range("C" & Rows.Count).End(xlUp).Row - 1
    For p = LBound(tablo, 1) To UBound(tablo, 1)
       If tablo(m, 3) = tablo(p, 1) Then
         acopier = tablo(p, 2)
       End If
    Next
  tablo(m, 4) = acopier
  acopier = "nok"
  Next
Range("A2").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
End Sub
 
Vote positif 0 Vote négatif
DoubleZero

DoubleZero

XLDnaute Barbatruc
Re : Comparaison

Bonjour à toutes et à tous,

Bienvenue sur XLD, guytares.

Une suggestion avec le code ci-après.

Code: 
Option Explicit
Sub Si_doublon()
    Dim c As Range, cc As Range
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    Columns(4).Clear
    For Each c In Sheets("Feuil1").Columns(3).SpecialCells(xlCellTypeConstants)
        Set cc = Sheets("Feuil1").Columns(1).Find(c.Value, LookIn:=xlValues)
        If Not cc Is Nothing Then c.Offset(0, 1) = cc.Offset(0, 1)
    Next
    Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub

A bientôt :)

P. S. : Bonjour, pierrejean :D

P. S. 2 : Bonjour, laetitia90 :D
 
Dernière édition:
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
Re : Comparaison

bonjour guytares ,pierrejean:):),DoubleZero:):)

sur 200000 lignes on pourrait tenter un dico ??

Code: 
Sub es()
 Dim t(), m As Object, i As Long
  Set m = CreateObject("Scripting.Dictionary")
  t = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
 For i = 1 To UBound(t): m(t(i, 1)) = t(i, 2): Next i
 t = Range("c2:d" & Cells(Rows.Count, 3).End(3).Row)
 For i = 1 To UBound(t)
 If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = t(i, 2)
  Next i
 [d2].Resize(UBound(t, 1), 1).Value = t
End Sub

ou en activant la ref.. Scripting.Dictionary un peu + rapide

Code: 
Sub est()
 Dim t(), m As New Dictionary, i As Long
  t = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
 For i = 1 To UBound(t): m(t(i, 1)) = t(i, 2): Next i
 t = Range("c2:d" & Cells(Rows.Count, 3).End(3).Row)
 For i = 1 To UBound(t)
 If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = t(i, 2)
  Next i
 [d2].Resize(UBound(t, 1), 1).Value = t
End Sub
 
Vote positif 0 Vote négatif
G

guytares

XLDnaute Nouveau
Re : Comparaison

Bonjour pierrejean, leatitia 90 et DoubleZero , vous m'avez tous rendu un sacré service et je suis impressionné par toutes vos contributions en si peux de temps, j'ai essayé toutes les solutions et la première réponse de laetitia90 a fonctionné de manière optimale 10 secondes pour 175000 lignes, j'en suis baba.Merci à tous
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Comparaison

Bonjour à tous.


VB: 
Sub tata()
Dim i&, j&, l&, m&, t, d(), e()
Dim ab1 As Range, ab2 As Range, c1 As Range, c2 As Range
  With Me
    l = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
    Set ab1 = .Cells(1, 1).Offset(1).Resize(l, 2).Cells
    m = .Cells(.Rows.Count, 3).End(xlUp).Row - 1
    Set c1 = .Cells(1, 3).Offset(1).Resize(m, 1).Cells
  End With
  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
  Sheets.Add After:=Sheets(Sheets.Count)
  With ActiveSheet
    ab1.Copy Destination:=.Range("A2")
    Set ab2 = .Cells(2, 1).Resize(l, 2).Cells
    With .Sort
      .SortFields.Add Key:=ab2.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange ab2
      .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
      .Apply
      .SortFields.Clear
    End With
    d = ab2.Value
    c1.Copy Destination:=.Range("E2")
    Set c2 = .Cells(2, 4).Resize(m, 3).Cells
    With c2.Cells(1, 1): .FormulaR1C1 = "nok": .AutoFill Destination:=c2.Columns(1), Type:=xlFillValues: End With
    With c2.Cells(1, 3): .FormulaR1C1 = "1": .AutoFill Destination:=c2.Columns(3), Type:=xlFillSeries: End With
    With .Sort
      .SortFields.Add Key:=c2.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange c2
      .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
      .Apply
      .SortFields.Clear
    End With
    e = c2.Value
    j = 1
    For i = 1 To m
      t = e(i, 2)
      Do While t > d(j, 1) And j < l: j = j + 1: Loop
      If t = d(j, 1) Then e(i, 1) = d(j, 2)
    Next
    c2.Value = e
    With .Sort
      .SortFields.Add Key:=c2.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange c2
      .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    c1.Offset(, 1).Value = c2.Value
    Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
  End With
  Me.Activate
  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub
Nettement plus rapide !​



ℝOGER2327
#7933

Lundi 9 Gidouille 142 (Sainte Outre, psychiatre - fête Suprême Quarte)
5 Messidor An CCXXIII, 1,0941h - mulet
2015-W26-2T02:37:33Z


P.s. : Correction du code, voir le message #9.
 
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Comparaison

Bonjur guytares.[SUP][1][/SUP]



guytares à dit:
Bonjour ℝOGER2327 et merci d'avoir répondu, votre macro est rapide mais il y a des nok quelquefois sur des comparaisons qui devraient être positive
Cliquez pour agrandir...
Je ne parviens pas à reproduire le comportement que vous décrivez. J'aimerais que vous déposiez un échantillon de données qui posent problème pour comprendre mon erreur.​


Merci d'avance.


ℝOGER2327
#7934

Lundi 9 Gidouille 142 (Sainte Outre, psychiatre - fête Suprême Quarte)
5 Messidor An CCXXIII, 3,9596h - mulet
2015-W26-2T09:30:11Z

________________________________________________
[SUP][1][/SUP]Voir le message suivant. Merci.
 
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Comparaison

Suite...


Je pense que vous ne devriez pas tenir compte du précédent message. Après vérification, je crois savoir d'où vient le problème : le code que j'ai conservé n'est pas celui que j'ai donné au message #6 ! (Le travail de nuit nuit.) C'est pourquoi je ne parviens pas à reproduire ce que vous me signalez.
La ligne :​
Code: 
      Do While t > d(j, 1) And j < m: j = j + 1: Loop
est erronée.

La ligne correcte est :​
Code: 
      Do While t > d(j, 1) And j < l: j = j + 1: Loop
Je corrige le message #6.
Dites-moi si cela règle le problème. Le cas échéant, je vous proposerai un code permettant un gain de vitesse de près de 10 %.​


Bonne journée.


ℝOGER2327
#7935

Lundi 9 Gidouille 142 (Sainte Outre, psychiatre - fête Suprême Quarte)
5 Messidor An CCXXIII, 4,9677h - mulet
2015-W26-2T11:55:21Z
 
Vote positif 0 Vote négatif
G

guytares

XLDnaute Nouveau
Re : Comparaison

ROGER2327
Bonjour et merci pour vos solutions, j'ai essayé le code original avec Do While t > d(j, 1) And j < l: j = j + 1: Loop
que vous avez mis en correction mais qui est aussi dans l'original, je vous joint un fichier avec les fausses erreurs en jaune. salutations
 

Pièces jointes

  • exemple2.xlsx
    11.5 KB · Affichages: 25
  • exemple2.xlsx
    11.5 KB · Affichages: 37
  • exemple2.xlsx
    11.5 KB · Affichages: 38
Vote positif 0 Vote négatif
G

guytares

XLDnaute Nouveau
Re : Comparaison

laetitia90 à dit:
bonjour guytares ,pierrejean:):),DoubleZero:):)

sur 200000 lignes on pourrait tenter un dico ??

Code: 
Sub es()
 Dim t(), m As Object, i As Long
  Set m = CreateObject("Scripting.Dictionary")
  t = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
 For i = 1 To UBound(t): m(t(i, 1)) = t(i, 2): Next i
 t = Range("c2:d" & Cells(Rows.Count, 3).End(3).Row)
 For i = 1 To UBound(t)
 If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = t(i, 2)
  Next i
 [d2].Resize(UBound(t, 1), 1).Value = t
End Sub

ou en activant la ref.. Scripting.Dictionary un peu + rapide

Code: 
Sub est()
 Dim t(), m As New Dictionary, i As Long
  t = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
 For i = 1 To UBound(t): m(t(i, 1)) = t(i, 2): Next i
 t = Range("c2:d" & Cells(Rows.Count, 3).End(3).Row)
 For i = 1 To UBound(t)
 If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = t(i, 2)
  Next i
 [d2].Resize(UBound(t, 1), 1).Value = t
End Sub
Cliquez pour agrandir...

Bonjour Laetitia90 j'ai une erreur de compilation sur le deuxième code ,type défini par l'utilisateur non défini et le debbugeur me souligne , m As New Dictionary.Merci à vous
 
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
Re : Comparaison

re tous :) roger:)

dans VBA dans le bandeau en haut tu selectionnes outils puis references tu deroules la combo
tu coches... Microsoft Scripting Runtime ... c'est tout

si tu y arrive pas lance cette macro qui le fait

Code: 
Sub runtime()
 On Error Resume Next
 ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\scrrun.dll"
 ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub

autrement 10 secondes un peu surprise!! ta quoi comme pc??

a moins que ton fichier beaucoup de formules

dans ce cas la je modifie un peu le code pour optimiser si evementielle adapte... rajoute .EnableEvents ect..


Code: 
Sub est()
 Dim t(), m As New Dictionary, i As Long
  With Application
  .Calculation = xlCalculationManual: .ScreenUpdating = 0: .DisplayAlerts = 0
  t = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
  For i = 1 To UBound(t): m(t(i, 1)) = t(i, 2): Next i
  t = Range("c2:d" & Cells(Rows.Count, 3).End(3).Row)
  For i = 1 To UBound(t)
  If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = t(i, 2)
   Next i
  [d2].Resize(UBound(t, 1), 1).Value = t
  .Calculation = xlCalculationAutomatic: .ScreenUpdating = 1: .DisplayAlerts = 1
End With
End Sub

pas pu tester code de roger:) With Me pas aime sur mon pc mais surement plus rapide
 
Vote positif 0 Vote négatif
G

guytares

XLDnaute Nouveau
Re : Comparaison

Bonjour Laetitia90, ca marche avec activation Microsoft Scripting Runtime, sinon quand je disais dix secondes c'est que avant ces macros performantes je mettais vingt minutes avec des MFC alors que maintenant c'est deux à trois secondes.
Si vous pouvez mettre le code pour rajouter 'nok' quand valeurs pas trouvée ce serait le top. Dans tout les cas merci à toi et à toutes les personnes du forum vous m'avez permis de gagner 19 mn 50 secondes à chaque opérations sur ma base.
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Comparaison

Re...


guytares à dit:
ROGER2327
Bonjour et merci pour vos solutions, j'ai essayé le code original avec Do While t > d(j, 1) And j < l: j = j + 1: Loop
que vous avez mis en correction mais qui est aussi dans l'original, je vous joint un fichier avec les fausses erreurs en jaune. salutations
Cliquez pour agrandir...
Décidément, je ne suis pas dans un bon jour. J'ai encore laissé une erreur dans la ligne
Code: 
If t = d(j, 1) Then e(i, 1) = d(j, 2)
qui doit être
Code: 
If t = d(j, 1) Then e(i, 1) = d(j, 2): j = j + 1

Le mieux est que je donne le code qui fonctionne (apparemment) chez moi :​
Code: 
Sub tata()
Const a$ = "A1", b$ = "C1" 'Début de la plage de données, début de la plage de résultats.
Dim i&, j&, l&, m&, t, d(), e()
Dim a1 As Range, a2 As Range, b1 As Range, b2 As Range
    With Me
        l = .Cells(.Rows.Count, .Range(a).Column).End(xlUp).Row - .Range(a).Row
        m = .Cells(.Rows.Count, .Range(b).Column).End(xlUp).Row - .Range(b).Row
        If l = 0 Or m = 0 Then Exit Sub
        Set a1 = .Range(a).Offset(1).Resize(l, 2).Cells
        Set b1 = .Range(b).Offset(1).Resize(m, 1).Cells
    End With
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
        a1.Copy Destination:=.Range("A2")
        Set a2 = .Cells(2, 1).Resize(l, 2).Cells
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=a2.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange a2
            .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
            .Apply
        End With
        d = a2.Value
        b1.Copy Destination:=.Range("E2")
        Set b2 = .Cells(2, 4).Resize(m, 3).Cells
        On Error Resume Next
        With b2.Cells(1, 1): .FormulaR1C1 = "nok": .AutoFill Destination:=b2.Columns(1), Type:=xlFillValues: End With
        With b2.Cells(1, 3): .FormulaR1C1 = "1": .AutoFill Destination:=b2.Columns(3), Type:=xlFillSeries: End With
        On Error GoTo 0
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=b2.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange b2
            .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
            .Apply
            e = b2.Value
            j = 1
            For i = 1 To m
                t = e(i, 2)
                Do While t > d(j, 1) And j < l: j = j + 1: Loop
                If t = d(j, 1) Then e(i, 1) = d(j, 2): j = j + 1
            Next
            b2.Value = e
            .SortFields.Clear
            .SortFields.Add Key:=b2.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange b2
            .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
        End With
        b1.Offset(, 1).Value = b2.Value
        Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
    End With
    Me.Activate
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub

Je l'ai installé dans le classeur joint. Voyez s'il donne satisfaction.

Une remarque que j'aurais peut-être dû faire plus tôt : pour fonctionner correctement, ce code exige que la colonne A, et la colonne C, soient non-vides et sans doublon.​


Bonne nuit.


ℝOGER2327
#7939

Mardi 10 Gidouille 142 (Saint Boudin, recteur - fête Suprême Quarte)
6 Messidor An CCXXIII, 0,0886h - romarin
2015-W26-3T00:12:46Z
 

Pièces jointes

  • Concordance.xlsm
    21.4 KB · Affichages: 32
Dernière édition:
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
Re : Comparaison

re tous & toutes :)

modifie cette ligne

Code: 
 If m.Exists(t(i, 1)) Then t(i, 1) = m(t(i, 1)) Else t(i, 1) = "nok"

j'ai teste sur le dernier fichier de l'ami roger :) fonctionne chez moi me bogue plus avec with Me
pas bien compris pourquoi ???


sur 100000 lignes +- 1.5 secondes dico2 a peu pres pareil enfin!!! sur mon pc
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Résolu(e)
XL 2013 Copier coller si valeur correspond
Réponses
7
Affichages
454
Stéfane
S
A
  • Question
XL 2019 Ajouter ou supprimer une ligne selon un mot trouvé dans une autre feuille
Réponses
1
Affichages
192
Oneida
Oneida
D
  • Question
Microsoft 365 Épurer les lignes vides d'une cellule puis fractionner la cellule en plusieurs lignes
2
Réponses
20
Affichages
365
fanch55
fanch55
S
  • Résolu(e)
Microsoft 365 Comparaison de colonnes
Réponses
4
Affichages
275
Stéfane
S
L
  • Question
Microsoft 365 Comparaison des cellules de deux tableaux avec les fonctions recherchev et/ou ESTNA
Réponses
9
Affichages
224
chris
chris
L
  • Question
Microsoft 365 Mémoriser la valeur d'une cellule qui change sous condition
Réponses
3
Affichages
407
Jacky67
Jacky67
J
  • Question
XL 2021 Classement avec ex aequo parfait
Réponses
3
Affichages
222
Jul1en
J
V
  • Question
XL 2019 Numéro d'ordre automatique
Réponses
1
Affichages
208
vilcoyotte90
V
Z
  • Question
Microsoft 365 Copier valeur cellule suivant le resultat d'une autre
Réponses
13
Affichages
376
Cousinhub
Cousinhub
3
  • Question
XL 2013 Recherche a plusieurs critéres
Réponses
2
Affichages
276
Gégé-45550
Gégé-45550

Membres actuellement en ligne

17 membres et 104 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
312 502
Messages
2 089 033
Membres
104 010
dernier inscrit
Freba