Comparaison

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion guytares
  • 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 !

S'inscrire
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

Trier par date Trier par votes
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
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 😀

P. S. 2 : Bonjour, laetitia90 😀
 
Dernière édition:
Vote positif 0 Vote négatif
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
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
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
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
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
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

Vote positif 0 Vote négatif
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
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
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
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

Dernière édition:
Vote positif 0 Vote négatif
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

Discussions similaires

Y
  • Question Question
Microsoft 365 Cdbl et nombres à virgules
Réponses
4
Affichages
262
Valtrase
Valtrase
P
  • Question Question
XL 2021 Macro de découpage suivant une clé
Réponses
14
Affichages
415
job75
job75
P
  • Résolu(e)
Microsoft 365 Comparaison 2 tableaux EXCEL différents
Réponses
12
Affichages
667
Peter DOE
P
S
  • Question Question
Microsoft 365 Problème avec formule INDEX et EQUIV
Réponses
4
Affichages
405
stoffer57
S
P
  • Résolu(e)
XL 2021 Formule avec SI ET et si possible plusieurs ET
Réponses
4
Affichages
218
PR.
P
M
  • Question Question
Microsoft 365 Chercher dernière valeur d'une ligne mais avec une particularité
Réponses
4
Affichages
248
Marie.
M
B
  • Question Question
XL 2016 resultat max égal trouver avec tout leurs noms
Réponses
9
Affichages
323
JHA
J
anthoYS
  • Question Question
XL 2019 Gestion de 4 sources de revenu (A, B, C et D). Et rajout du jour en cours et MEFC qui doit varier selon le mois en cours...
Réponses
8
Affichages
186
sylvanu
sylvanu
Jiheme
  • Question Question
XL 2019 Macro bloque en court de travail
Réponses
4
Affichages
305
fanch55
fanch55
S
  • Résolu(e)
Microsoft 365 Actualiser formules matricielles
Réponses
3
Affichages
195
Standpi
S
F
  • Question Question
Autres Récupération de données d'une feuille X en fonction de la valeur de cellule dans une collone d'une feuille Y
2
Réponses
27
Affichages
1 K
fanfan38
fanfan38
F
  • Question Question
XL 2016 travail sur tableau
2 3 4
Réponses
55
Affichages
2 K
finarobert
F
V
  • Résolu(e)
Microsoft 365 transposer
Réponses
6
Affichages
245
vincenot
V
N
  • Question Question
XL 2021 Décompter des valeurs qui se répètent sur deux feuilles
Réponses
3
Affichages
200
Hecatonchire
H
G
  • Question Question
XL 2016 filtrer, copier et coller les données avec la macro
Réponses
4
Affichages
233
job75
job75
P
  • Question Question
Microsoft 365 Sommeprod avec Liste de variables
2
Réponses
15
Affichages
492
patricko-13
P
F
Fdaga
Réponses
0
Affichages
156
Fdaga
F
A
  • Résolu(e)
Microsoft 365 VBA_Copier coller selon des critères dans deux menus déroulants
Réponses
6
Affichages
344
Altfkat
A
P
  • Résolu(e)
Microsoft 365 Macro Excel pour effectuer des opérations sur les lignes et cellules adjacentes
2
Réponses
19
Affichages
670
Perceval973
P
treza88
  • Résolu(e)
XL 2021 Problème réaffectation variable Objet
Réponses
2
Affichages
180
treza88
treza88
Retour