Temps d'exécution trop long

Bonjour,

J'ai une macro excel qui effectue une boucle et une comparaison et recopie les cellules. Doit comparer une à une environ 120 données ("j" dans la boucle") avec la valeur des cellule c.value (environ 13 000 données)

J'ai mis en début et fin de macro

Application.ScreenUpdating = False

Application.Calculation = xlManual

Ensuite, j'ai réduit au maximum le code et sorti le maximum d'opération de la boucle mais la boucle tourne encore en environ 20 secondes.. elle revient 6 fois dans ma macro... Voici la boucle, si vous avez des idées pour l'Accélérer, j'aimerais bien les connaître!

Merci!

    ThisWorkbook.Sheets("10").Activate
    For Each c In Sheets("COORD").Range("B2:B25000").Cells
        If c.Value <> "0" Then
        If c.Value <> "" Then
            DDT = c.Value
            j = 9
            Do While Cells(j, 4).Value <> ""
                If Cells(j, 23).Value = DDT Then
                    If Cells(j, 23).Value <> Cells(j - 1, 23).Value Then
                       Cells(j, 24).Value = c.Offset(0, 4).Value
                       Cells(j, 25).Value = c.Offset(0, 2).Value
                       Cells(j, 26).Value = c.Offset(0, 7).Value
                    End If
                End If
            j = j + 1
            Loop
        End If
        End If
      Next c

'Calcul du temps d'exécution
Workbooks("Cédule.xls").Sheets("Indicateurs").Range("A20") = j Workbooks("Cédule.xls").Sheets("Indicateurs").Range("A17") = GetTickCount() - temps1 '!

  ThisWorkbook.Sheets("10").Activate
    For Each c In Sheets("COORD").Range("B2:B25000").Cells
        If c.Value <> "0" And c.Value <> "" Then
            DDT = c.Value
            j = 9
            Do While Cells(j, 4).Value <> ""
                If Cells(j, 12).Value = DDT Then
                    If Cells(j, 12).Value <> Cells(j - 1, 12).Value Then
                        Cells(j, 15).Value = c.Offset(0, 7).Value
                    End If
                End If
            j = j + 1
            Loop
        End If
    Next c

Workbooks("Cédule.xls").Sheets("Indicateurs").Range("A18") = GetTickCount() - temps1

Bonsoir,

Merci de mettre un fichier en ligne ce sera plus facile de comprendre et de refaire le fichier pour proposer quelque chose.

A priori, je ne vois pas à quoi peut servir la première instruction... à moins que l'on compare deux feuilles ??

Amicalement