Ameliorer un code vba Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
l
lechiffre
Jeune membre
Jeune membre
Messages : 48
Inscrit le : 21 mars 2016
Version d'Excel : 2010 FR

Message par lechiffre » 18 avril 2018, 21:41

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,
Avatar du membre
Dan
Modérateur
Modérateur
Messages : 5'785
Appréciations reçues : 72
Inscrit le : 27 avril 2007
Version d'Excel : 2010, 2000, Mac 2004, 2011

Message par Dan » 18 avril 2018, 21:59

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
@+ Dan ;)
l
lechiffre
Jeune membre
Jeune membre
Messages : 48
Inscrit le : 21 mars 2016
Version d'Excel : 2010 FR

Message par lechiffre » 19 avril 2018, 21:31

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,
Avatar du membre
Dan
Modérateur
Modérateur
Messages : 5'785
Appréciations reçues : 72
Inscrit le : 27 avril 2007
Version d'Excel : 2010, 2000, Mac 2004, 2011

Message par Dan » 19 avril 2018, 21:49

re

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

Cordialement
@+ Dan ;)
l
lechiffre
Jeune membre
Jeune membre
Messages : 48
Inscrit le : 21 mars 2016
Version d'Excel : 2010 FR

Message par lechiffre » 20 avril 2018, 22:07

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,
doublons_livraison.xlsm
(16.86 Kio) Téléchargé 11 fois
Avatar du membre
Dan
Modérateur
Modérateur
Messages : 5'785
Appréciations reçues : 72
Inscrit le : 27 avril 2007
Version d'Excel : 2010, 2000, Mac 2004, 2011

Message par Dan » 23 avril 2018, 08:40

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
@+ Dan ;)
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 7'788
Appréciations reçues : 211
Inscrit le : 16 juin 2013
Version d'Excel : 2013 UK Windows 10

Message par h2so4 » 23 avril 2018, 11:41

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
l
lechiffre
Jeune membre
Jeune membre
Messages : 48
Inscrit le : 21 mars 2016
Version d'Excel : 2010 FR

Message par lechiffre » 23 avril 2018, 18:19

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,
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message