Sub ResumePlanningNewClasseur()
Dim WB As Workbook
Dim S As Worksheet
Dim Coll As New Collection
Dim var
Dim i&
Dim j&
Dim k&
Dim cpt& 'compteur
Dim cpt2& 'compteur
Dim bool As Boolean
Dim A$
Dim T()
Dim T2()
'---
var = ActiveSheet.[c1].CurrentRegion.Value
On Error Resume Next
For i& = 2 To UBound(var, 1)
For j& = 5 To UBound(var, 2)
A$ = var(i&, j&)
If A$ <> "" And A$ <> "-" Then
Coll.Add A$, A$
End If
Next j&
Next i&
Err.Clear
On Error GoTo 0
'---
For k& = 1 To Coll.Count
A$ = Coll(k&)
For i& = 2 To UBound(var, 1)
cpt2& = 3
bool = False
For j& = 5 To UBound(var, 2)
If var(i&, j&) = A$ Then
If Not bool Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 11, 1 To cpt&)
T(1, cpt&) = A$
T(2, cpt&) = var(i&, 3) & " " & var(i&, 4)
bool = True
End If
T(cpt2&, cpt&) = var(1, j&)
cpt2& = cpt2& + 1
End If
Next j&
Next i&
Next k&
'---
If Coll.Count = 0 Then
MsgBox "Avez-vous sélectionné une feuille ''Planning'' valide ?"
Exit Sub
End If
'---
ReDim Preserve T(1 To UBound(T, 1), 1 To UBound(T, 2) + 1)
T = Application.WorksheetFunction.Transpose(T)
'---
Set WB = Workbooks.Add(xlWBATWorksheet)
'---
cpt& = 1
For i& = 1 To UBound(T, 1)
ReDim Preserve T2(1 To UBound(T, 2), 1 To cpt&)
If cpt& = 1 Then
For j& = 1 To UBound(T, 2)
T2(j&, cpt&) = T(i&, j&)
Next j&
Else
If T(i&, 1) = T(i& - 1, 1) Then
For j& = 1 To UBound(T, 2)
T2(j&, cpt&) = T(i&, j&)
Next j&
Else
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
S.Name = T(i& - 1, 1)
S.Range(S.Cells(1, 1), S.Cells(UBound(T2, 2), UBound(T2, 1))) = Application.WorksheetFunction.Transpose(T2)
cpt& = 0
Erase T2
i& = i& - 1
End If
End If
cpt& = cpt& + 1
Next i&
Application.DisplayAlerts = False
WB.Sheets(1).Delete
Application.DisplayAlerts = True
End Sub