Sub Répartir()
Dim TR(), n%, i%, np$, clr&
With Worksheets("Liste")
'Ajout colonne pour ordonner tri domaine en musique / parole / danse
'Tri et effacement colonne ajoutée
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To n
If .Cells(i, 5) Like "*MUSIQUE*" Then
.Cells(i, 7) = 1 & .Cells(i, 3)
ElseIf .Cells(i, 5) Like "*PAROLE*" Then
.Cells(i, 7) = 2 & .Cells(i, 3)
ElseIf .Cells(i, 5) Like "*DANSE*" Then
.Cells(i, 7) = 3 & .Cells(i, 3)
End If
Next i
.Range("A2:G" & n).Sort key1:=.Range("A2"), order1:=xlAscending, key2:=.Range("B2"), _
order2:=xlAscending, key3:=.Range("G2"), order3:=xlAscending, Header:=xlNo
.Range("G2:G" & n).ClearContents
'Recueil des données
ReDim TR(n - 1, 3)
For i = 2 To n
np = .Cells(i, 1) & " " & .Cells(i, 2)
If np <> TR(0, 1) Then TR(i - 1, 1) = np
TR(0, 1) = np
TR(i - 1, 2) = .Cells(i, 3)
TR(i - 1, 3) = .Cells(i, 4) & " (" & .Cells(i, 6) & ")"
If .Cells(i, 5) Like "*MUSIQUE*" Then
TR(i - 1, 0) = 1
ElseIf .Cells(i, 5) Like "*PAROLE*" Then
TR(i - 1, 0) = 3
ElseIf .Cells(i, 5) Like "*DANSE*" Then
TR(i - 1, 0) = 5
End If
Next i
End With
'Affectation nouveau tableau
With Worksheets("Répartition")
For i = 1 To n - 1
.Cells(i + 2, 2) = TR(i, 1)
.Cells(i + 2, 2 + TR(i, 0)) = TR(i, 2)
.Cells(i + 2, 3 + TR(i, 0)) = TR(i, 3)
Next i
'Coloration
For i = 0 To 4 Step 2
With Range("C2:D2").Offset(, i)
clr = .Interior.Color
.Resize(n).Interior.Color = clr
End With
Next i
'Formule col. A et bordure tour colonne
With .Range("A3")
.Formula = "=If(B3<>"""",Counta($B$3:B3),"""")"
.AutoFill .Resize(n - 1)
With .Resize(n - 1)
.HorizontalAlignment = xlCenter
.BorderAround xlContinuous, xlThin
End With
End With
'Bordures tableau
With .Range("A3:H" & n + 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
'Formules récapitulatives
''.Range("C" & n + 3).Formula = "=Counta(C3:C" & n + 1 & ")"
'' .Range("D" & n + 3).FormulaArray = "=Sum(If(R3C:R" & n + 1 & "C<>"""",Value(Mid(R3C:R" _
'' & n + 1 & "C,Len(R3C:R" & n + 1 & "C)-1,1)),0))"
'' .Range("C" & n + 3 & ":D" & n + 3).Copy
'' .Range("E" & n + 3).PasteSpecial xlPasteAll
'' .Range("G" & n + 3).PasteSpecial xlPasteAll
''.Range("C" & n + 3 & ":H" & n + 3).HorizontalAlignment = xlCenter
End With
End Sub