Bonsoir,
Je viens de tester les anomalies que tu as observées :
1- Avec diff de 1 jour et CP à 2 j'ai 71 résultats.
2- avec diff de 1 jour et CP à 5 j'ai 46 résultats.
Résultats normal car il y a plus de convoyage entre deux départements qu'entre deux communes.
J'ai toujours les mêmes résultats avec les mêmes critères.
3- Il ne peut y avoir de critère -1 uniquement 1 et plus.
Donc tout marche parfaitement sur ma bécane.
Pour le fichier avec plus de critères de sélection, cogite bien la chose et poste le classeur tel qu'il devra être au final ainsi que les critères de sélection que tu envisages. Je changerai le code afin d'adapter la macro aux nouvelles conditions.
Option Explicit
Sub Regroupement()
Dim i As Long, n As Long, aller As String, retour As String
Dim dico As Object, e
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Feuil1")
With .Range("a1").CurrentRegion
For i = 2 To .Rows.Count
aller = Join$(Array(.Rows(i).Cells(1), .Rows(i).Cells(3), .Rows(i).Cells(6)), Chr(2))
retour = Join$(Array(.Rows(i).Cells(1), .Rows(i).Cells(6), .Rows(i).Cells(3)), Chr(2))
If Not dico.exists(aller) Then
Set dico(aller) = Union(.Rows(1), .Rows(i))
If aller <> retour Then
Set dico(retour) = Nothing
End If
Else
If dico(aller) Is Nothing Then
Set dico(retour) = Union(dico(retour), .Rows(i))
Else
Set dico(aller) = Union(dico(aller), .Rows(i))
End If
End If
Next
End With
End With
Application.ScreenUpdating = False
'restitution
With Sheets("Feuil2")
.Cells.Clear
For Each e In dico
If Not dico(e) Is Nothing Then
n = n + 1
dico(e).Copy .Cells(n, 1)
With .Cells(n, 1).CurrentRegion
n = n + .Rows.Count
End With
End If
Next
.Cells.EntireColumn.AutoFit
.Activate
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set dico = Nothing
End Sub
aller = Join$(Array(.Rows(i).Cells(1), .Rows(i).Cells(3), .Rows(i).Cells(6)), Chr(2))
retour = Join$(Array(.Rows(i).Cells(1), .Rows(i).Cells(6), .Rows(i).Cells(3)), Chr(2))
aller = Join$(Array(.Rows(i).Cells(3), .Rows(i).Cells(6)), Chr(2))
retour = Join$(Array(.Rows(i).Cells(6), .Rows(i).Cells(3)), Chr(2))
Option Explicit
Sub test1()
Dim dico As Object, i As Long, n As Long, txt1 As String, txt2 As String, e, s
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Feuil1").Range("a1").CurrentRegion
For i = 2 To .Rows.Count
txt1 = Join$(Array(.Cells(i, 3), .Cells(i, 6)), " - ")
txt2 = Join$(Array(.Cells(i, 6), .Cells(i, 3)), " - ")
If Not dico.exists(txt1) Then
Set dico(txt1) = CreateObject("Scripting.Dictionary")
dico(txt1).CompareMode = 1
If txt1 <> txt2 Then
Set dico(txt2) = Nothing
End If
If Not dico(txt1).exists(.Cells(i, 1).Value) Then
Set dico(txt1)(.Cells(i, 1).Value) = .Rows(1)
End If
Set dico(txt1)(.Cells(i, 1).Value) = Union(dico(txt1)(.Cells(i, 1).Value), .Rows(i))
Else
If dico(txt1) Is Nothing Then
If Not dico(txt2).exists(.Cells(i, 1).Value) Then
Set dico(txt2)(.Cells(i, 1).Value) = .Rows(i)
Else
Set dico(txt2)(.Cells(i, 1).Value) = Union(dico(txt2)(.Cells(i, 1).Value), .Rows(i))
End If
Else
If Not dico(txt1).exists(.Cells(i, 1).Value) Then
Set dico(txt1)(.Cells(i, 1).Value) = .Rows(i)
Else
Set dico(txt1)(.Cells(i, 1).Value) = Union(dico(txt1)(.Cells(i, 1).Value), .Rows(i))
End If
End If
End If
Next
Application.ScreenUpdating = False
'restitution
With Sheets("Feuil2")
.Cells.Clear
For Each e In dico
If Not dico(e) Is Nothing Then
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 3
If n = 4 Then n = 1
With .Cells(n, 1).Resize(, 7)
.Merge
.HorizontalAlignment = xlCenter
.Value = UCase(e)
.Font.Size = 16
End With
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 1
For Each s In dico(e)
dico(e)(s).Copy .Cells(n, 1)
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 2
Next
End If
Next
.Cells.EntireColumn.AutoFit
With .UsedRange.Rows
.SpecialCells(4).RowHeight = 9
.SpecialCells(2).RowHeight = 18
End With
.Activate
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set dico = Nothing
End With
End Sub
Option Explicit
Sub test2()
Dim a, w(), e, s, i As Long, j As Long, n As Long
Dim dico As Object, txt1 As String, txt2 As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
txt1 = Join$(Array(a(i, 3), a(i, 6)), " - ")
txt2 = Join$(Array(a(i, 6), a(i, 3)), " - ")
If Not dico.exists(txt1) Then
Set dico(txt1) = CreateObject("Scripting.Dictionary")
dico(txt1).CompareMode = 1
If txt1 <> txt2 Then
Set dico(txt2) = Nothing
End If
If Not dico(txt1).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 2)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2) - 1) = a(1, j)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = Union(.Rows(1), .Rows(i))
End If
Else
If dico(txt1) Is Nothing Then
If Not dico(txt2).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt2)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt2)(.Cells(i, 1).Value) = .Rows(i)
Else
w = dico(txt2)(a(i, 1))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt2)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt2)(.Cells(i, 1).Value) = Union(dico(txt2)(.Cells(i, 1).Value), .Rows(i))
End If
Else
If Not dico(txt1).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = .Rows(i)
Else
w = dico(txt1)(a(i, 1))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = Union(dico(txt1)(.Cells(i, 1).Value), .Rows(i))
End If
End If
End If
Next
Application.ScreenUpdating = False
'restitution
With Sheets("Feuil2")
.Cells.Clear
For Each e In dico
If Not dico(e) Is Nothing Then
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 3
If n = 4 Then n = 1
With .Cells(n, 1).Resize(, 7)
.Merge
.HorizontalAlignment = xlCenter
.Value = UCase(e)
.Font.Size = 16
End With
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 1
For Each s In dico(e)
w = dico(e)(s)
.Cells(n, 1).Resize(UBound(w, 2), UBound(w, 1)).FormulaLocal = _
Application.Transpose(w)
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 2
Next
End If
Next
.Cells.EntireColumn.AutoFit
With .UsedRange.Rows
.SpecialCells(4).RowHeight = 9
.SpecialCells(2).RowHeight = 18
End With
.Activate
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub