répartiton immo avec macro j'y perds mes cheveux!

Sub RepartirImmo()
  Dim I As Long, Feuillecible As String, DerL As Long
  ' Pour chaque ligne de la feuille immo
  For I = 4 To Sheets("IMMO").Range("A4").End(xlDown).Row
    ' Récupérer le nom de la feuille
    Feuillecible = Sheets("IMMO").Cells(I, 2).Text
    ' En cas d'erreur on continue
    On Error Resume Next
    ' Activer la feuille
    Sheets(Feuillecible).Activate
    ' Si erreur = la feuille n'existe pas
    If Err.Number <> 0 Then
      ' Créer la feuille
      Sheets.Add After:=Sheets(Sheets.Count)
      ' la nommer
      Sheets(Sheets.Count).Name = Feuillecible
    End If
    On Error GoTo 0
    ' Inscrire les valeurs dedans
    With Sheets(Feuillecible)
      DerL = .Range("A65536").End(xlUp).Row + 1
      .Range(.Cells(5, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 4)).ClearContents
      .Range("A" & DerL) = Sheets("IMMO").Cells(I, 1).Value
      .Range("B" & DerL) = Sheets("IMMO").Cells(I, 4).Value
      .Range("C" & DerL) = Sheets("IMMO").Cells(I, 5).Value
      .Range("D" & DerL) = Sheets("IMMO").Cells(I, 13).Value
    End With
  Next I
End Sub

Sub ListFonts()

   Dim varFont As Variant
   ' Speeds macro processing and suppresses display.
   Application.ScreenUpdating = False
   ' Create new document.
   Documents.Add Template:="normal"

   ' Loop through each available font.
   For Each varFont In FontNames
      With Selection
         ' Format for name of font.
         .Font.Name = "times new roman"
         .Font.Bold = True
         .Font.Underline = True
         ' Insert Font name.
         .TypeText varFont
         ' Insert a new paragraph after the Font Name.
         .InsertParagraphAfter
         ' Move to the new paragraph.
         .MoveDown unit:=wdParagraph, Count:=1, Extend:=wdMove
         ' Format for the font example.
         .Font.Bold = False
         .Font.Underline = False
         .Font.Name = varFont
         ' Enter example text(Alphabetic characters.)
         .TypeText "abcdefghijklmnopqrstuvwxyz"
         ' Insert a new paragraph.
         .InsertParagraphAfter
         ' Move to the new paragraph.
         .MoveDown unit:=wdParagraph, Count:=1, Extend:=wdMove
         ' Insert example text(Numeric characters.)
         .TypeText "0123456789?$%&()[]*_-=+/<>"
         ' Insert two new paragraphs and move down.
         .InsertParagraphAfter
         .InsertParagraphAfter
         .MoveDown unit:=wdParagraph, Count:=1, Extend:=wdMove
      End With

   Next varFont
   Application.ScreenUpdating = True

End Sub