Ameliorer un code VBA

Bonsoir le forum, bonsoir les intervenants,

J'ai adapté un code pour repérer les répétitions de certaines informations par ligne sur mon fichier, cependant la macro ne répond pas quand je l'exécute sur un fichier a plus de 10 000 ligne par exemple.

Voici le code en question :

Sub test ()

Dim w As Long, j As Long, x As Long

With Sheets("Feuil1")

j = .Range("a" & .Rows.Count).End(xlUp).Row

For w = j To 13 Step -1

For x = w - 1 To 12 Step -1

If .Range("a" & w) & .Range("b" & w) & .Range("d" & w) & .Range("g" & w) & .Range("m" & w) = .Range("a" & x) & .Range("b" & x) & .Range("d" & x) & .Range("g" & x) & .Range("m" & x) Then

If .Range("k" & w) <> .Range("k" & x) Then

.Range("a" & w).EntireRow.Interior.ColorIndex = 3

End If

End If

Next x

Next w

End With

End Sub

Si un intervenant à une solution ou un conseil, je suis preneur.

Au besoin je peux joindre un fichier.

Je vous remercie d'avance pour votre aide.

Bonne soirée.

Cordialement,

Bon soir

Peut être comme ceci ?

Sub test()
Dim w As Long, j As Long, x As Long
Dim PlageW As Range, PlageX As Range

With Sheets("Feuil1")
    j = .Range("a" & .Rows.Count).End(xlUp).Row

    For w = j To 13 Step -1
        Set PlageW = Union(.Range("a" & w), .Range("b" & w), .Range("d" & w), .Range("g" & w), .Range("m" & w))

        For x = w - 1 To 12 Step -1
            Set PlageX = Union(.Range("a" & x), .Range("b" & x), .Range("d" & x), .Range("g" & x), .Range("m" & x))

            If PlageW = PlageX Then
                If .Range("k" & w) <> .Range("k" & x) Then .Range("a" & w).EntireRow.Interior.ColorIndex = 3
            End If
        Next x

Next w

End With
End Sub

Cordialement

Bonsoir le forum, bonsoir Dan,

Je vous remercie pour votre contribution Dan.

J'ai fait un test aujourd'hui sur mon fichier, mais malheureusement le code ne retourne pas le résultat attendu et s'exécute très lentement aussi.

Je vais essayer de creuser un peu.

Bonne soirée le forum,

Cordialement,

re

Mettez votre fichier en ligne. ce sera plus facile de comprendre

Cordialement

Bonsoir le forum, bonsoir Dan,

Ci-joint un fichier test pour illustrer ce que je souhaiterais obtenir via la macro :

Identifier les livraison en double pour les mêmes clients, à des jours différents.

Je précise que le fichier sur lequel je travail fait plus de 10 000 ligne.

Merci pour votre aide.

Bonne soirée le forum.

Cordialement,

Re,

Essayez déjà ce code

Sub test()
With Worksheets(1).Range("A12:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
    .RemoveDuplicates Columns:=Array(1, 2, 6), Header:=xlNo
End With
End sub

A vérifier suivant vos données réelles

Faites quelques tests et trier vos données sur la date de livraison.

Cordialement

Bonjour à tous,

un essai. En triant les données on devrait pouvoir sensiblement améliorer les performances. (temps dépend du nombre de lignes, plutôt que du carré du nombre de lignes)

Sub aargh()
    Set r = Nothing
    With Sheets("test")
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("A12:A" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("D12:D" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("F12:F" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("M12:M" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("K12:K" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange .Range("A11:M" & dl)
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
        For i = 12 To dl - 1
            d = True
            For Each j In Split("A,D,F,M", ",")
                If .Cells(i, j) <> .Cells(i + 1, j) Then d = False: Exit For
            Next
            If d Then If r Is Nothing Then Set r = .Cells(i + 1, 1).Resize(, 13) Else Set r = Union(r, .Cells(i + 1, 1).Resize(, 13))
        Next i
        r.Interior.ColorIndex = 3
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("D12:D" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("A12:A" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("M12:M" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("K12:K" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("F12:F" & dl), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange .Range("A11:M" & dl)
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
End Sub

Bonjour le forum, bonjour Dan et h2so4,

J'ai réalisé un premier test sur mon fichier et le résultat est concluant, exécution parfaite.

Merci beaucoup Dan et h2so4 pour votre aide.

Bonne journée à tous.

Cordialement,

Rechercher des sujets similaires à "ameliorer code vba"