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,