J'ai repris ton code et ce que j'ai souligné c'est ce que j'ai adapté, et ce qui est en gras c'est ce que où je me demande si il faut l'adapter aussi.
Suis-je à coté de la plaque ou pas loin ?
En tous cas, mille merci !
Sub ModifTexte()
Dim Cel As Range
Dim Depart As String
'**Colorie les lignes**
Set Cel = Columns(1).Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlPart)
If Not Cel Is Nothing Then
Depart = Cel.Address
Do
Rows(Cel.Row).Font.ColorIndex = 3
Set Cel = Columns(1).FindNext(Cel)
Loop While Not Cel Is Nothing And Cel.Address <> Depart
End If
'**creer la nouvelle feuille**
On Error Resume Next 'On s'affranchit de toute les erreurs dans le code
Sheets("Semaine").Visible = True 'Mettre sa propriété Visible à True
'(offre une valeur d'erreur:0 si la feuille existe)
Faute = Err.Number 'recupere le n° d'erreur
On Error GoTo 0 'réinitialise les erreurs
If Faute > 0 Then 'si..alors*
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Range("A1").Value ' a remplacer par ce que tu veux (meme range("A1").value par exemple)
Else 'sinon...*
MsgBox "Feuille existante"
Exit Sub
End If '...fin d'if*
'**transfere les lignes rouges vers la Semaine**
Sheets("feuille d'arrivé").Activate
lignesuiv = Cells(Rows.Count, 1).End(xlUp).Row + 1 'ligne vide suivante
Sheets("feuille source").Activate
For i = 1 To 529
If Rows(Cel.Row).Font.ColorIndex = 3 Then
Rows(Cel.Row).Copy Sheets(Range("A1").Value).Range("A" & lignesuiv)
End If
Next i