Macro très lente, comment y remédier?

Bonjour,

Je dois repérer toutes les lignes d'une BD1 (suivant 3 critères) dans une autre BD2 (dans BD2 elles sont en doublons).

Quand une occurrence est trouvée on met le fond de la cellule colonne1 en rouge et on reporte le n° de ligne est colonne 29.

Le nombre de lignes à rechercher (BD1) est conséquent (1920) et en BD2 environ 30.000. Ma macro met un peu plus de 6 minutes.

Je sollicite votre aide pour améliorer le temps d’exécution de cette macro. En vous remerciant par avance.

Option Explicit

Public Sub RechercheCopie()
Dim Lig As Long, nBD1 As Long, nBD2 As Long, I As Long, J As Long, t As Long
t = Timer
  ' Détermine la dernière ligne dans chaque page
  '
  nBD1 = Sheets("BD1").Range("A" & Rows.Count).End(xlUp).Row
  nBD2 = Sheets("BD2").Range("B" & Rows.Count).End(xlUp).Row

  With Sheets("BD2")
  .Columns(1).Interior.Pattern = xlNone     'efface le fond de cellule
  .Columns(29).Clear                        'efface

    For I = 2 To nBD2
    Lig = 0
      For J = 2 To nBD1
        If .Cells(I, 4) = Sheets("BD1").Cells(J, 3) And _
        .Cells(I, 5) = Sheets("BD1").Cells(J, 4) And _
        .Cells(I, 7) = Sheets("BD1").Cells(J, 5) Then
        Lig = J
          Exit For
        End If
      Next J
      If Lig > 0 Then
      .Cells(I, 1).Interior.Color = vbRed
        .Cells(I, 29) = J
      End If
    Next I
  End With

  MsgBox Timer - t

End Sub

Même compressé, je n'ai pas pu joindre le fichier, il dépasse la capacité autorisée.

bonjour,

voici une proposition

Option Explicit

Public Sub RechercheCopie()
    Dim Lig As Long, nBD1 As Long, nBD2 As Long, I As Long, J As Long, t As Long, bd1, re
    t = Timer
    ' Détermine la dernière ligne dans chaque page
    '
    Set bd1 = Sheets("bd1")
    nBD1 = bd1.Range("A" & Rows.Count).End(xlUp).Row
    bd1.Columns(1).Insert shift:=xlToRight
    bd1.Range("A2:A" & nBD1).formular1c1= "=rc4 & rc5 & rc6"

    With Sheets("BD2")
        nBD2 = .Range("B" & Rows.Count).End(xlUp).Row
        .Columns(1).Interior.Pattern = xlNone     'efface le fond de cellule
        .Columns(29).Clear                        'efface

        For I = 2 To nBD2
            Set re = bd1.Range("A:A").Find(.Cells(I, 4) & .Cells(I, 5) & .Cells(I, 7), lookat:=xlWhole)
            If re Is Nothing Then
            Else
                .Cells(I, 1).Interior.Color = vbRed
                .Cells(I, 29) = re.Row
            End If
        Next I
    End With
    bd1.Columns(1).Delete shift:=xlLeft
    MsgBox Timer - t
End Sub

Bonsoir H2So4,

Je te remercie pour ta proposition. En effet, le temps d’exécution a considérablement diminué, mais au final le résultat escompté n'est pas au rendez-vous.

 bd1.Columns(1).Insert shift:=xlToRight
    bd1.Range("A2:A" & nBD1) = "=rc4 & rc5 & rc6"

dans la colonne rajoutée il n'y a aucune donnée

au lieu de rajouter une colonne, j'ai modifié pour utiliser le colonne 12 (L)

bd1.Range("L2:L" & nBD1).FormulaR1C1 = "=RC[-9]&RC[-8]&RC[-7]"
'ainsi j'ai la concaténation des cellules en colonne L

et au lieu de supprimer la colonne A (colonne ajoutée), j'efface tout ce qui se trouve en colonne 12.

Malgré cela, à la fin je n'ai rien, ni fond de cellule en rouge, ni n° de ligne. Je n'ai pas compris pourquoi?

En te remerciant beaucoup.

Re,

j'ai réduit considérablement mon fichier afin de pouvoir le joindre.

Je crois que H2So4, n'a pas compris que l'on doit boucler sur toutes les lignes de la feuille BD1. On recherche toutes les occurrences de BD1 dans BD2. Il doit y avoir 2 boucles une pour BD1 et une pour BD2.

Je pense que la solution est l'utilisation des tableaux qui hélas je ne maitrise pas bien. Voilà, je joins le fichier ça sera plus clair.

Merci beaucoup.

Bonjour

En utilisant la fonction Find sur concaténation

Dim cal, t: Application.ScreenUpdating = False
cal = Application.Calculation: Application.Calculation = xlCalculationManual
t = Timer

'**************
Dim vBD1, rBD1 As Range, trouve As Range
Dim i As Long, valConcat As String

    With Sheets("BD1"):  vBD1 = .Range("C2").Resize(.Range("C" & .Rows.Count).End(xlUp).Row - 1, 3): End With
    Set rBD1 = Sheets("BD1").Range("IV2").Resize(UBound(vBD1))
    For i = LBound(vBD1) To UBound(vBD1) - 1: rBD1.Cells(i) = vBD1(i, 1) & "_" & vBD1(i, 2) & "_" & vBD1(i, 3): Next i

    With Sheets("BD2")
        .Columns(1).Interior.Pattern = xlNone
        .Columns(29).Clear

          For i = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
              valConcat = .Cells(i, 4) & "_" & .Cells(i, 5) & "_" & .Cells(i, 7)

              Set trouve = rBD1.Find(what:=valConcat, LookIn:=xlValues, lookat:=xlWhole)
              If Not trouve Is Nothing Then .Cells(i, 29) = trouve.Row: .Cells(i, 1).Interior.Color = vbRed
          Next i
    End With

    rBD1.EntireColumn.Delete
    Set rBD1 = Nothing
    Set trouve = Nothing
    Erase vBD1
'**************

  Application.ScreenUpdating = True
  Application.Calculation = cal
  MsgBox Timer - t

Bonsoir Habitude,

Vraiment tu es un champion, C'est extra-ordinaire, ton code répond exactement à mes attentes et en plus, il est beaucoup plus rapide que le mien. Je ne l'ai pas encore essayé sur ma base de données.

J'ai remis en forme ton code pour essayer de le comprendre. Je ne suis pas très fort en vba. je n'ai pas compris certaines de tes lignes signalées par des astérisques. Pourrais-tu me donner une explication?

Public Sub Habitude()
Dim cal, t
Application.ScreenUpdating = False
cal = Application.Calculation         '*****pas compris avec ce qu'il y a à la fin du code
Application.Calculation = xlCalculationManual
t = Timer
'**************
Dim vBD1, rBD1 As Range, trouve As Range
Dim i As Long, valConcat As String

    With Sheets("BD1")
    vBD1 = .Range("C2").Resize(.Range("C" & .Rows.Count).End(xlUp).Row - 1, 3)      '***
'   vBD1 est un tableau, mais je n'ai pas compris cette notation avec Resize
    End With    
    Set rBD1 = Sheets("BD1").Range("L2").Resize(UBound(vBD1))
    For i = LBound(vBD1) To UBound(vBD1) - 1
    rBD1.Cells(i) = vBD1(i, 1) & "_" & vBD1(i, 2) & "_" & vBD1(i, 3)
    Next i

    With Sheets("BD2")
        .Columns(1).Interior.Pattern = xlNone
        .Columns(29).Clear

          For i = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
              valConcat = .Cells(i, 4) & "_" & .Cells(i, 5) & "_" & .Cells(i, 7)

              Set trouve = rBD1.Find(what:=valConcat, LookIn:=xlValues, lookat:=xlWhole)
              If Not trouve Is Nothing Then .Cells(i, 29) = trouve.Row: .Cells(i, 1).Interior.Color = vbRed
          Next i
    End With

        rBD1.EntireColumn.Delete
    Set rBD1 = Nothing
    Set trouve = Nothing
    Erase vBD1
'**************
  Application.ScreenUpdating = True
  Application.Calculation = cal      '********* pas compris avec ce qu'il y au début code
'c'est peut-être Application.Calculation=xlCalculationAutomatic
  MsgBox Timer - t
  End Sub

En te remerciant sincèrement. Bonne soirée à tous.

Bonjour

avec ce code je ne fais que garder en mémoire ton mode de calculation (manuel, auto, semi-auto)

cal = Application.Calculation

A la fin je remets le même mode.

Application.Calculation = cal

ICI

vBD1 = .Range("C2").Resize(.Range("C" & .Rows.Count).End(xlUp).Row - 1, 3)

Je redimensionne le vecteur à partir de la cellule C2.

Le déplacement est de ***.Range("C" & .Rows.Count).End(xlUp).Row - 1**** ligne et 3 colonnes

Je te remercie beaucoup pour ton aide et tes explications.

Tu viens de me donner un sacré coup de main. En effet, là j'avance mieux.

Avec ton code sur ma base de données, le temps d’exécution est passé de plus de 6mn à 15sec.

c'est super, ça m'a permis de repérer beaucoup d'anomalies.

Merci beaucoup, bonne soirée.