XL 2010 Plusieurs écritures dans une même cellule ( Résolu )

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, tablo, i&, x$
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
If FilterMode Then ShowAllData 'si la feuille est filtrée

Set r = Intersect(Target, Range("A3:A" & Rows.Count), UsedRange)
For Each r In r 'si entrées multiples (copier-coller)
    If r <> "" And r(1, 6) = "" Then r(1, 6) = Now
    If r = "" And r(1, 6) <> "" Then r(1, 6) = ""
Next r

Set r = Intersect(Target, Range("D3:D" & Rows.Count), UsedRange)
For Each r In r.Areas 'si entrées multiples (copier-coller)
    tablo = r.Resize(, 2) 'matrice plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        x = UCase(Replace(tablo(i, 1), " ", ""))
        If Left(x, 6) = "DEVIS" Then
            tablo(i, 1) = "DEVIS " & Mid(x, 7)
        ElseIf x <> "" Then
            tablo(i, 1) = Left(x, 1) & " " & Mid(x, 2)
        End If
    Next i
    r = tablo 'restitution
Next r

Application.EnableEvents = True
End Sub