Macro pour cree des lignes dans une cellule ayant plusieurs donnees

Sub Ventiler()
Dim fin As Range, ici As Range
Dim finLig As Long, i As Long, j As Long, isplit As Long

Application.ScreenUpdating = False
With Sheets("Feuil2")
  'fin des lignes sources
  Set fin = .Cells(.Rows.Count, "a").End(xlUp)
  'cellule de la ligne d'écriture
  Set ici = fin.Offset(1, 0)
  'n° dernière lignes sources
  finLig = fin.Row
  'effacement lignes après données source
  .Range(ici, .Cells(.Rows.Count, "j")).Clear
  'boucle sur les lignes sources
  For i = 9 To finLig
    'nombre de destinations de la ligne à traiter
    isplit = 1 + UBound(Split(.Cells(i, "H"), Chr(10)))
    'écriture des 7 premières colonnes
    ici.Resize(, 7).Value = .Cells(i, "a").Resize(, 7).Value
    'écriture des colonnes H,I et J
    ici.Offset(, 7).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "H"), Chr(10)))
    ici.Offset(, 8).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "I"), Chr(10)))
    ici.Offset(, 9).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "J"), Chr(10)))
    'fusion des colonnes A à G
    For j = 1 To 7
      With ici.Offset(, j - 1).Resize(isplit)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .MergeCells = True
      End With
    Next j
    'Appliquer bordure aux lignes écrites
    ici.Resize(isplit, 10).Borders.LineStyle = xlContinuous
    'prochaine cellule où écrire
    Set ici = ici.Offset(1)
  Next i
  'effacer lignes sources
  .Range(.Range("A9"), .Cells(finLig, "j")).Delete xlShiftUp
End With

Application.ScreenUpdating = True
End Sub