Code lourd si les lignes sont nombreuses

[jp65]

Bonjour le forum


J'ai récupéré sur un forum les éléments d'un code que j'ai adapté à mon besoin.
Le code fonctionne mais si le nombre de ligne est important, excel ne demande qu'à planter.
Voici le code:

Sub Répartition()

Set TAB1 = Sheets("Nomenclature client")
Set TAB2 = Sheets("Condensé")

     For i = 1 To 1000
     For n = 1 To 1000
     If TAB1.Cells(i, 4).Value = TAB2.Cells(n, 2).Value Then
     TAB1.Cells(i, 8).Value = TAB2.Cells(n, 6).Value
     End If
 Next
 Next
 
End Sub

Si je défini un nombre de ligne plus léger il n'y a aucun signe de ralentissement.
Le but du code est de récupérer dans la feuille Condensé les valeurs des cellules d'une colonne ( F ) lorsqu'il i y a
des cellules communes entre les feuilles Nomenclature client ( colonne D )et Condensé ( colonne B ).
Une fois la valeur commune trouvée, la valeur de la cellule dans Condensée (colonne F) est copiée dans la ligne correspondante à la valeur commune en feuille Nomenclature client ( colonne H ).
Je joint un fichier pour mettre des images sur les mots.


Merci pour votre aide

 

[ChTi160]

Re : Code lourd si les lignes sont nombreuses

Bonjour jp65
Bonjour le fil
Bonjour le Forum

Une idée comme une autre , passer par des tableaux pour accélérer la boucle .

Sub Répartition()

'on definit les Variables
Dim WS_Cible As Worksheet
Dim Ws_Source  As Worksheet
Dim DerLgn As Integer
Dim DerCol As Byte
Dim i As Integer
Dim ii As Integer
Dim TAB_Cible As Variant
Dim TAB_Source As Variant
Set WS_Cible = Sheets("Nomenclature client") 'on definit la variable
Set Ws_Source = Sheets("Condensé")           'on definit la variable
Application.ScreenUpdating = False 'On inibe le défilement de l'ecran
With WS_Cible 'avec la feuille "Nomenclature client"
      DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row 'on definit la dernière ligne non vide de la colonne "A" ou 1
      DerCol = .Cells(2, .Columns.Count).End(xlToLeft).Column 'on definit la dernière colonne non vide de la ligne 2 "Entetes"
   TAB_Cible = .Range(.Cells(2, 1), .Cells(DerLgn, DerCol)).Value 'on récupére les donnees de la plage ainsi definie
End With
With Ws_Source 'avec la feuille "Condensé"
      DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row 'on definit la derniere ligne non vide de la colonne "A" ou 1
      DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'on definit la derniere colonne non vide de la ligne 2 "Entetes"
  TAB_Source = .Range(.Cells(1, 1), .Cells(DerLgn, DerCol)).Value 'on récupére les donnees de la plage ainsi definie
     
End With
  For i = 2 To UBound(TAB_Cible, 1) 'pour chaque ligne du tableau "des donnees cibles
     For ii = 2 To UBound(TAB_Source, 1) 'pour chaque ligne du tableau "des donnees Sources
        If TAB_Cible(i, 4) = TAB_Source(ii, 2) Then 'si egalite entre les valeur des colonne 4 et 2
            WS_Cible.Cells(1 + i, 8) = TAB_Source(ii, 6)  'on colle dans la cellule de la ligne correspondante en Colonne 8 la valeur de la colonne 6 du tableau source
            Exit For 'on quitte la boucle
        End If
     Next ii
 Next i 
Application.ScreenUpdating = True 'Onréinitialise le défilement de l'ecran
End Sub

Le Fichier : Regarde la pièce jointe Préparation devis-MAX_V2.xlsm

Bonne journée
Amicalement
Jean Marie

 

[Patrice33740]

Re : Code lourd si les lignes sont nombreuses

Bonjour le Forum
Bonjour jp65

Pourquoi pas une simple formule ? :

=INDEX(Condensé!F:F;EQUIV(D3;Condensé!B:B;0))

 

[jp65]

Re : Code lourd si les lignes sont nombreuses

Bonjour Chti160, tatiak, Patrice33740

J'ai tout testé et tout fonctionne parfaitement.

J'ai fait le test sur 1000 lignes.
Avec le code initial il faut 14,5s de traitement.
Avec le code de Chti160 il faut 0.17s de traitement.
Avec le code de tatiak il faut 0,18s de traitement.
Avec la formule de Patrice33740 c'est bien sur immédiat mais pour une ligne.

Un grand merci à vous trois pour vos réponses aussi rapides qu'efficaces, avec en plus le choix entre vba et formule.

Bonne soirée.

 

[klin89]

Re : Code lourd si les lignes sont nombreuses

Bonsoir à tous,

Avec un dictionnaire :

Sub Correspondance()
Dim a, b(), i As Long, e
    a = Sheets("Condensé").Range("a1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            .Item(a(i, 2)) = a(i, 6)
        Next
        With Sheets("Nomenclature client").Range("a1").CurrentRegion
            a = .Value
            b = .Columns(8).Value
        End With
        For i = 3 To UBound(a, 1)
            For Each e In .keys
                If UCase(a(i, 4)) = UCase(e) Then
                    b(i, 1) = .Item(e)
                    Exit For
                End If
            Next
        Next
    End With
    Sheets("Nomenclature client").Range("a1").CurrentRegion.Columns(8).Value = b
End Sub

klin89

 

[Patrice33740]

Re : Code lourd si les lignes sont nombreuses

Re,

Si tu cherches un code simple et très rapide (0,07 s pour 10 000 lignes) , essaies :

Sub Répartition()

  With Worksheets(1).Range("H3:H" & Range("A" & Rows.Count).End(xlUp).Row)
    .FormulaR1C1 = "=INDEX(Condensé!C[-2],MATCH(RC[-4],Condensé!C[-6],0))"
    .Value = .Value
  End With

End Sub

 

[laetitia90]

Re : Code lourd si les lignes sont nombreuses

bonjour tous
une version avec un dico egalement < a 1 seconde sur 100000 lignes sur chaque sheet
je passe par une liaison tardive moins rapide a adapter .....activer ref..scripting Runtime... plus modif variable dans le code

avec l'exemple

Sub es()
  Dim t, t1, t2, i As Long, s As Long, m As Object ', m As Dictionary
  Set m = CreateObject("Scripting.Dictionary")
  ' Set m = New Dictionary
   t = Feuil2.Range("d2:d" & Feuil2.Cells(Rows.Count, 1).End(3).Row)
   t2 = Feuil1.Range("b2:f" & Feuil1.Cells(Rows.Count, 2).End(3).Row)
  ReDim t1(1 To UBound(t), 1 To 1)
  For i = 1 To UBound(t2)
  If Not m.Exists(t2(i, 1)) Then m.Add t2(i, 1), t2(i, 5)
  Next i
  For i = 1 To UBound(t)
  If m.Exists(t(i, 1)) Then t1(i, 1) = m(t(i, 1))
  Next i
  Feuil2.Range("h2").Resize(UBound(t1), 1) = t1
 End Sub