XL 2010 tableau pour comparer deux colonnes et écrire le résultat dans une troisième colonne

zephir94 · 15 Mai 2023

Bonjour à tous,

Pour gagner en temps de traitement, je souhaiterais passer à un tableau pour gagner en temps de traitement
car ma base peut aller jusqu'à 27000 lignes.

J'ai deux colonnes avec des chiffres et je veux comparer la 3 -ème colonnes avec la première et écrire si trouvé
la valeur de la cellule dans la 4 -ème colonnes.

Pour faire cela j'avais écrit :

VB:

R3 = Sheets(6).Range("F65536").End(xlUp).Row
For Ri = 2 To R3 Step 1
a = Sheets(12).Range("E" & Ri).Value
Set d = Sheets(12).Range("A2" & ":A" & R1).Find(Val(a), , xlValues)
If Not d Is Nothing Then
trv = d.Row
Sheets(12).Range("H" & Ri).Value = Sheets(12).Range("B" & trv).Value
Else
Sheets(12).Range("H" & Ri).Value = "0"
End If
Next Ri

Je voudrais remplacer cela par un tableau, le problème est que je ne maitrise pas encore les tableaux !
Je sollicite votre aide pour essayer d'une part comprendre les tableaux, d'autre part réussir à passer ma
boucle vers un tableau.
J'ai commencé mais je reste un peu perdu !

VB:

R3 = Sheets(1).Range("A65536").End(xlUp).Row
R8 = Sheets(1).Range("C65536").End(xlUp).Row
Dim tableau()
ReDim tableau(R3, R8)
MsgBox UBound(tableau, 1)
    MsgBox UBound(tableau, 2)

J'ai constitué un fichier test, il faudrait comparer colonne A avec Colonne C, si on trouve la valeur de la colonne C en A, on récupère la valeur
de la Cellule correspondante en B et on vient la copier en D sur la Cellule correspondante.

Je vous remercie par avance pour toute l'aide que vous pourrez m'apporter.

Bien à vous

zephir94 · 17 Mai 2023

Bonsoir à tous,

Je penses que certains ici vont perdre un œil en lisant mon code
Je me suis lancé avec les tableaux
Je me suis aperçu que j'avais des apostrophes dans deux colonnes, je me suis donc arrangé pour
les virer.
Comme pour premier code je trouve bien les mêmes récurrences mais en un temps record
Un grand merci CP4 pour le temps que tu as passé a écrire ce code pour moi, merci à tous les autres également.

VB:

Sub test()
Application.ScreenUpdating = False
Dim Tb()
Dim Tb1()
Dim Tb2()
Dim Tb3()
R1 = Sheets(1).Range("F65536").End(xlUp).Row
R2 = Sheets(1).Range("H65536").End(xlUp).Row
ReDim Tb(R1)
ReDim Tb1(R1)
ReDim Tb2(R2)
ReDim Tb3(R2)
Dim cel As Range
Sheets(1).Range("F2" & ": F" & R1).Select ' On retire les apostrophes
For Each cel In Selection
cel.Value = cel.Value
Next
For i = 2 To R1
Tb(i) = Sheets(1).Range("F" & i).Value
Tb1(i) = Sheets(1).Range("G" & i).Value
Next
For j = 2 To R2
Tb2(j) = Sheets(1).Range("H" & j).Value
Next
For u = 2 To R2
a = Tb2(u)
 For k = 2 To R1
If Tb(k) = a Then
Tb3(u) = Tb1(k)
Exit For
Else
Tb3(u) = "0"
End If
Next k
Next u
For O = 2 To R2
Sheets(1).Range("I" & O).Value = Tb3(O)
Next
Application.ScreenUpdating = True
End Sub

CP4, je vais essayer de comprendre ton code et améliorer le mien.
Si l'un d'entre vous peut me proposer une amélioration, je suis humblement preneur
Bonne soirée a vous tous.

cp4 · 17 Mai 2023

zephir94 à dit:
Bonsoir à tous,

Je penses que certains ici vont perdre un œil en lisant mon code
Je me suis lancé avec les tableaux
Je me suis aperçu que j'avais des apostrophes dans deux colonnes, je me suis donc arrangé pour
les virer.
Comme pour premier code je trouve bien les mêmes récurrences mais en un temps record
Un grand merci CP4 pour le temps que tu as passé a écrire ce code pour moi, merci à tous les autres également.

VB:

Sub test() Application.ScreenUpdating = False Dim Tb() Dim Tb1() Dim Tb2() Dim Tb3() R1 = Sheets(1).Range("F65536").End(xlUp).Row R2 = Sheets(1).Range("H65536").End(xlUp).Row ReDim Tb(R1) ReDim Tb1(R1) ReDim Tb2(R2) ReDim Tb3(R2) Dim cel As Range Sheets(1).Range("F2" & ": F" & R1).Select ' On retire les apostrophes For Each cel In Selection cel.Value = cel.Value Next For i = 2 To R1 Tb(i) = Sheets(1).Range("F" & i).Value Tb1(i) = Sheets(1).Range("G" & i).Value Next For j = 2 To R2 Tb2(j) = Sheets(1).Range("H" & j).Value Next For u = 2 To R2 a = Tb2(u) For k = 2 To R1 If Tb(k) = a Then Tb3(u) = Tb1(k) Exit For Else Tb3(u) = "0" End If Next k Next u For O = 2 To R2 Sheets(1).Range("I" & O).Value = Tb3(O) Next Application.ScreenUpdating = True End Sub

CP4, je vais essayer de comprendre ton code et améliorer le mien.
Si l'un d'entre vous peut me proposer une amélioration, je suis humblement preneur
Bonne soirée a vous tous.

Si ça peut t'aider, le code commenté.

VB:

Option Explicit

Sub Trouver_Prix()
   Dim d1 As Object, plage1 As Range, plage2 As Range, t As Double, c As Range
   t = Timer   'pour mesurer le temps d'execution du code on initialise la variable "t"
   Set d1 = CreateObject("Scripting.Dictionary")   'on définit (crée) un dictionnaire
   Set plage1 = Range("A2", [a65000].End(xlUp))   'on définie la 1ère plage
   Set plage2 = Range("c2", [c65000].End(xlUp))   'on définie la 2ème plage

   [A:C].Interior.ColorIndex = xlNone   'on réinitialise la couleur des cellules
   [D:D].ClearContents   'on vide la colonne D

   For Each c In plage1   'on parcourt toutes les cellules de la plage1 colonne A
      d1(CDbl(c.Value)) = c.Offset(, 1).Value   'on récupère via dictionnaire d1 (sans doublon)- la paire (Key,Item)
   Next c

   For Each c In plage2   'on parcourt toutes les cellules de la plage colonne C
      If d1.exists(c.Value) Then c.Interior.ColorIndex = 3   'si la valeur (key) existe dans le dictionnaire d1, on colorie la cellule
      If d1.exists(c.Value) Then c.Offset(, 1) = d1.Item(CDbl(c))   'si la valeur existe(key) dans le dictionnaire d1, on récupère L'item correspondant à la clé (key)
   Next c
   MsgBox "Terminé en " & Round(Timer - t, 2) & " sec."
End Sub

cp4 · 17 Mai 2023

zephir94 à dit:
Comme pour premier code je trouve bien les mêmes récurrences mais en un temps record

Ce n'est pas pour te décourager, mais chez-moi ton code ne donne rien (en colonne I)

zephir94 · 17 Mai 2023

cp4 à dit:
Ce n'est pas pour te décourager, mais chez-moi ton code ne donne rien (en colonne I)

Oui car j'ai changé les colonnes, voici le fichier, peut on utiliser Find dans un tableau ? n'ayant pas réussi du coup dans la deuxième boucle j'ai mis un exit for, partant du principe que si j'avais trouvé la valeur, je n'avais pas besoin de continuer la boucle !

cp4 · 17 Mai 2023

zephir94 à dit:
peut on utiliser Find dans un tableau ?

Je t'avoue que je ne suis pas un AS des tableaux. Je n'ai jamais utilisé Find dans un tableau. Mais sur le lien de mon post, il est dit que c'est possible ici

zephir94 · 17 Mai 2023

cp4 à dit:
Je t'avoue que je ne suis pas un AS des tableaux. Je n'ai jamais utilisé Find dans un tableau. Mais sur le lien de mon post, il est dit que c'est possible ici

Merci Cp4, je vais aller voir, as tu testé du fait avec le nouveau fichier avec les nouvelles colonnes ?

laurent950 · 17 Mai 2023

Bonsoir @cp4, le forum

VB:

Sub test()
Dim t() As Variant
t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
ReDim Preserve t(LBound(t, 1) To UBound(t, 1), LBound(t, 1) To 4)
    For i = LBound(t, 1) To UBound(t, 1)
        For j = LBound(t, 1) To UBound(t, 1)
            If CStr(t(i, 3)) = CStr(t(j, 1)) Then
                t(i, 4) = t(j, 2)
            End If
        Next j
    Next i
    Cells(2, 4).Resize(UBound(t, 1), 1).Value = Application.Index(t, , 4)
End Sub

zephir94 · 17 Mai 2023

laurent950 à dit:

Bonsoir @cp4, le forum

VB:

Sub test()
Dim t() As Variant
t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
ReDim Preserve t(LBound(t, 1) To UBound(t, 1), LBound(t, 1) To 4)
    For i = LBound(t, 1) To UBound(t, 1)
        For j = LBound(t, 1) To UBound(t, 1)
            If CStr(t(i, 3)) = CStr(t(j, 1)) Then
                t(i, 4) = t(j, 2)
            End If
        Next j
    Next i
    Cells(2, 4).Resize(UBound(t, 1), 1).Value = Application.Index(t, , 4)
End Sub

Bonsoir, un grand merci pour cette solution

laurent950 · 17 Mai 2023

Bonsoir,

Code plus rapide

VB:

Sub test22()
timerAvant = Timer
Dim t() As Variant
t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
ReDim Preserve t(LBound(t, 1) To UBound(t, 1), LBound(t, 1) To 4)
'
Dim t1() As Variant 'Liste 1 colonne C (Nombre de lignes)
t1 = Range(Cells(2, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3))
'
Dim t2() As Variant 'Liste 2 Colonne A  (Nombre de lignes)
t2 = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 1))
'
    For i = LBound(t1) To UBound(t1)
            For j = LBound(t2) To UBound(t2)
            If CStr(t(i, 3)) = CStr(t(j, 1)) Then
                    t(i, 4) = t(j, 2)
                End If
            Next j
    Next i
    Range("D2").Resize(UBound(t, 1), 1).Value = Application.Index(t, , 4)
MsgBox "Temps d'exécution : " & Timer - timerAvant & " secondes."
End Sub

cp4 · 18 Mai 2023

Bonjour,

@laurent950

: Ravi de te rencontrer, merci beaucoup pour ton exemple d'utilisation de la fonction Find avec un array. Avec ton exemple, tu viens de démontrer à @zephir94 que les arrays ne sont pas dans les cas plus rapides.
Excellente journée à vous.

edit: @zephir94 , avec array et dictionary. ça prend un plus de temps que mon premier code.

VB:

Option Explicit
Option Compare Text
Sub Dico_Array()
   Dim d1 As Object, d2 As Object, t As Double, T1, T2
   Dim Tean(), Tpx(), Tv(), i As Long, j As Long
   Dim Ws As Worksheet
   Set Ws = ThisWorkbook.Sheets("feuil1")

   t = Timer
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   'on récupère les plages à comparer dans des arrays
   T1 = Ws.Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row).Value
   T2 = Ws.Range("C1:C" & Cells.SpecialCells(xlCellTypeLastCell).Row).Value
   '--------------------------------------------------------------------------
   For i = 1 To UBound(T1)
      d1(CStr(T1(i, 1))) = T1(i, 2)   'boucle pour récupérer paire (clé,item) sans doublons
   Next i

   If d1.Count > 0 Then
      Tean = d1.keys   'on passe le dictionnaire à un array (clé)
      Tpx = d1.items   'on passe le dictionnaire à un array (item)
   End If
   '--------------------------------------------------------------------------

   For i = 1 To UBound(T2)
      d2(CStr(T2(i, 1))) = ""   'boucle pour récupérer valeurs sans doublons
   Next i

   If d2.Count > 0 Then Tv = Application.Transpose(d2.keys)   'on récupère dans l'array Tv, la transposée du dictionnaire
   ReDim Preserve Tv(1 To UBound(Tv), 1 To 2)   'on redimensionne tout en préservant les données-on ne peut redimensionner que la seconde dimension (soit le 2) car d1.keys est un array à 1 dimension
   'boucle pour récupérer les prix
   For i = 1 To UBound(Tv)
      For j = 0 To UBound(Tean)
         Tv(i, 1) = CStr(Tv(i, 1))
         If Tv(i, 1) = Tean(j) Then Tv(i, 2) = Tpx(j)
      Next j
   Next i
   'restitution
   Ws.[E:F].ClearContents
   Ws.Range("E1").Resize(UBound(Tv), 2) = Tv
   Ws.Range("E1").Resize(UBound(Tv), 1).NumberFormat = "0"
   Ws.Range("E1").Offset(, 1).Resize(UBound(Tv), 1).NumberFormat = "0.00"
   Set Ws = Nothing
   Set d1 = Nothing
   Set d2 = Nothing
   MsgBox "Terminé en " & Round(Timer - t, 2) & " sec."
End Sub

laurent950 · 19 Mai 2023

Bonjour @cp4

j'ai repris pour essaie ton premier code en poste #12 (Super code merci @cp4)
en utilisant : CreateObject("Scripting.Dictionary") et que des variables Tableaux

VB:

Sub test()
T1 = Timer
Dim Dico As Object
    Set Dico = CreateObject("Scripting.Dictionary")
Dim t() As Variant
    t = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
        ReDim Preserve t(LBound(t, 1) To UBound(t, 1), LBound(t, 1) To 4)
        Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3)).Interior.ColorIndex = xlNone
        Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3)).Offset(, 3).Resize(, 1).ClearContents
Dim i As Long
    For i = LBound(t, 1) To UBound(t, 1)
       Dico(CDbl(t(i, 1))) = t(i, 2)
    Next i
    i = Empty
    For i = LBound(t, 1) To UBound(t, 1)
        If Dico.exists(t(i, 3)) Then
            t(i, 4) = Dico.Item(CDbl(t(i, 3)))
        End If
    Next i
    Cells(2, 5).Resize(UBound(t, 1), 1).Value = Application.Index(t, , 4)
MsgBox "Terminé en " & Round(Timer - T1, 2) & " sec."
End Sub

que des variables tableaux

laurent950 · 19 Mai 2023

Re @cp4

toujours en partant de ton premier code en poste #12 (Super code merci @cp4)
j'ai repris ton premier code en poste #12
en utilisant : CreateObject("Scripting.Dictionary") et que des variables Tableaux et des Ranges

Code:

Sub test()
Tps = Timer
Dim Dico As Object
    Set Dico = CreateObject("Scripting.Dictionary")
Dim t(0 To 1) As Variant
Dim tpivo As Variant
    t(0) = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
    tpivo = t(0)
    ReDim Preserve tpivo(LBound(tpivo, 1) To UBound(tpivo, 1), LBound(tpivo, 1) To 4)
    t(0) = tpivo: Erase tpivo
    Set t(1) = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 3))
        t(1).Interior.ColorIndex = xlNone
        t(1).Offset(, 3).Resize(, 1).ClearContents

Dim i As Long
    For i = LBound(t(0), 1) To UBound(t(0), 1)
        t(0)(i, 1) = CDbl(t(0)(i, 1))
        Dico(t(0)(i, 1)) = t(0)(i, 2)
    Next i
    i = Empty
    For i = LBound(t(0), 1) To UBound(t(0), 1)
        If Dico.exists(t(0)(i, 3)) Then
            t(0)(i, 4) = Dico.Item(t(0)(i, 3))
            t(1)(i, 3).Interior.ColorIndex = 3
        End If
    Next i
    Cells(2, 5).Resize(UBound(t(0), 1), 1).Value = Application.Index(t(0), , 4)
MsgBox "Terminé en " & Round(Timer - Tps, 2) & " sec."
End Sub

cp4 · 19 Mai 2023

Bonsoir @laurent950 ,

Il n'y a que le demandeur qui ne se manifeste pas. Il a dû faire un MégaPont. un peu jaloux que des corvées.
Bonne soirée.

zephir94 · 21 Mai 2023

Bonjour,

Merci à vous tous pour vos réponses, je vais essayer de comprendre toutes les propositions que vous m'avez faites, sachant que, j'ai grâce à vous tous trouvé mon bonheur !
Encore merci pour le temps que vous m'avez donné.

XL 2010 tableau pour comparer deux colonnes et écrire le résultat dans une troisième colonne

zephir94

XLDnaute Impliqué

Pièces jointes

zephir94

XLDnaute Impliqué

cp4

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

zephir94

XLDnaute Impliqué

Pièces jointes

cp4

XLDnaute Barbatruc

zephir94

XLDnaute Impliqué

laurent950

XLDnaute Barbatruc

zephir94

XLDnaute Impliqué

laurent950

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

zephir94

XLDnaute Impliqué

Discussions similaires