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

zephir94

XLDnaute Impliqué
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
 

Pièces jointes

  • Classeur1.xlsm
    264.8 KB · Affichages: 31

zephir94

XLDnaute Impliqué
Bonsoir à tous,

Je penses que certains ici vont perdre un œil en lisant mon code o_O
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

XLDnaute Barbatruc
Bonsoir à tous,

Je penses que certains ici vont perdre un œil en lisant mon code o_O
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
 

zephir94

XLDnaute Impliqué
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 !
 

Pièces jointes

  • Classeur1.xlsm
    337.6 KB · Affichages: 10
Dernière édition:

laurent950

XLDnaute Accro
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

XLDnaute Impliqué
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

XLDnaute Accro
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
 
Dernière édition:

cp4

XLDnaute Barbatruc
Bonjour,

@laurent950 ;):cool:: 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
 
Dernière édition:

laurent950

XLDnaute Accro
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

XLDnaute Accro
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
 

zephir94

XLDnaute Impliqué
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é.
 

Discussions similaires

Réponses
4
Affichages
165

Statistiques des forums

Discussions
311 720
Messages
2 081 892
Membres
101 831
dernier inscrit
gillec