Supprimer les renvoies chariots inutiles dans la même cellule

Option Explicit

Sub NettoieActiveCell()
    ActiveCell.Value = ValeurCellule(ActiveCell)
End Sub

Sub NettoieActiveSheet()
    Dim Cellule As Range

    For Each Cellule In ActiveSheet.UsedRange
        Cellule.Value = ValeurCellule(Cellule)
    Next Cellule
End Sub

Function ValeurCellule(Cellule As Range) As Variant
    Dim i As Integer
    Dim Bool As Boolean
    Dim Texte As String

    'Init Return Value
    ValeurCellule = Cellule.Value

    If VarType(Cellule.Value) <> vbString Then Exit Function
    If Len(Cellule.Value) = 0 Then Exit Function

    Texte = Cellule.Value
    Bool = True

    'Élimine les doubles Chr(10)
    i = 1
    Do While i <= Len(Texte)
        If Mid(Texte, i, 1) = Chr(10) Then
            If Bool Then
                Texte = Left(Texte, i - 1) & Mid(Texte, i + 1)
                i = i - 1
            Else
                Bool = True
            End If
        Else
            Bool = False
        End If
        i = i + 1
    Loop

    'Élimine le Char(10) de la fin
    If Right(Texte, 1) = Chr(10) Then Texte = Left(Texte, Len(Texte) - 1)
    'MsgBox "<" & Texte & ">"

    'Return Value
    ValeurCellule = Texte

End Function

Range("A1").Value = Chr(10) & "blabla blablaa" & Chr(10) & Chr(10) & "blabla blablaa" & Chr(10)
  Range("A1").Value = Replace(WorksheetFunction.Trim(Replace(Replace(Range("A1").Value, " ", Chr(1)), Chr(10), " ")), Chr(1), Chr(10))

Chr(10) ' a supprimer<--------------------------------celui là le premier si premier il y a
15/03/2016 : cour de badminton Ce1Chr(10) ' on garde

Chr(10) ' a supprimer
15/03/2016 : cour de badminton Ce1Chr(10) ' on garde
17/04/2016 : Initiation de foot en salleChr(10) ' on garde
Chr(10) ' a supprimer
Chr(10) ' a supprimer
03/05/2016 : Match de Basket Cm1 vs Cm2Chr(10) ' on garde
Chr(10) ' a supprimer