Sub Répartition()
Dim DLig As Long, Lig As Long, NLig As Long
Dim ShtS As Worksheet, ShtD As Worksheet
' Définir la feuille source
Set ShtS = Sheets("Feuil1")
' Déterminer le numéro de la dernière ligne
DLig = ShtS.Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Définir la feuille de destination
On Error Resume Next
Set ShtD = Sheets(ShtS.Range("R" & Lig).Value)
If Err.Number <> 0 Then
Err.Clear ' Effacer l'erreur
' La feuille n'existe pas, il faut donc la créer
Sheets.Add After:=Sheets(Sheets.Count)
' Avec la feuille créée
With ActiveSheet
' Lui donner le nom
.Name = ShtS.Range("R" & Lig)
' Remplir la ligne d'entête
.Range("A1") = ShtS.Range("H1")
.Range("B1") = ShtS.Range("C1")
.Range("C1") = ShtS.Range("AD1")
.Range("E1") = ShtS.Range("J1")
.Range("F1") = ShtS.Range("A1")
End With
' Définir la feuille de destination
Set ShtD = ActiveSheet
End If
On Error GoTo 0
' Déterminer la nouvelle ligne à écrire
NLig = ShtD.Range("A" & Rows.Count).End(xlUp).Row + 1
' Inscrire les différentes valeurs
ShtD.Range("A" & NLig) = ShtS.Range("H" & Lig)
ShtD.Range("B" & NLig) = ShtS.Range("C" & Lig)
ShtD.Range("C" & NLig) = ShtS.Range("AD" & Lig)
ShtD.Range("E" & NLig) = ShtS.Range("J" & Lig)
ShtD.Range("F" & NLig) = ShtS.Range("A" & Lig)
Next Lig
End Sub