Problème d'automatisatiion

'### Constantes à adapter selon votre usage ###
Const FEUILLE As String = "test"
Const CELLULE_DEPART As String = "a2"
'##############################################

Sub DateDebit2Tableau()
Dim S As Worksheet
Dim R As Range
Dim var
Dim i&
Dim j&
Dim cpt&
Dim T()
Dim Titres
Titres = Array("debit", "date_debut", "", "date_fin")
On Error Resume Next
Set S = ActiveWorkbook.Sheets(FEUILLE)
If Err <> 0 Then
  MsgBox "La feuille ''" & FEUILLE & "'' est introuvable."
  Exit Sub
End If
On Error GoTo 0
Set R = S.Range(CELLULE_DEPART).CurrentRegion
var = R.Value
If UBound(var, 2) > 256 Then
  MsgBox "La plage ''Date - Débit'' est limitée à 255 colonnes.", _
    Title:="Limitez à 255 colonnes"
  Exit Sub
End If
For j& = 2 To UBound(var, 2)
  If IsEmpty(var(1, j&)) Or Not IsDate(var(1, j&)) Then
    S.Activate
    S.Range(S.Cells(2, j&), S.Cells(2, j&)).Select
    MsgBox "La cellule n'est pas une date."
    Exit Sub
  End If
  If IsEmpty(var(2, j&)) Or Not IsNumeric(var(2, j&)) Then
    S.Activate
    S.Range(S.Cells(3, j&), S.Cells(3, j&)).Select
    MsgBox "La cellule n'est pas un nombre."
    Exit Sub
  End If
Next j&
cpt& = 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = var(2, 2)
T(2, cpt&) = CLng(var(1, 2))
T(4, cpt&) = T(2, cpt&) 'par défaut - temporaire
For j& = 3 To UBound(var, 2)
  If var(2, j&) <> var(2, j& - 1) Then
    cpt& = cpt& + 1
    T(4, cpt& - 1) = CLng(var(1, j& - 1))
    ReDim Preserve T(1 To 4, 1 To cpt&)
    T(1, cpt&) = var(2, j&)
    T(2, cpt&) = CLng(var(1, j&))
    T(4, cpt&) = T(2, cpt&) 'par défaut - temporaire
  End If
  If j& = UBound(var, 2) Then
    T(4, cpt&) = CLng(var(1, j&))
  End If
Next j&
Application.ScreenUpdating = False
On Error GoTo Erreur
Set S = Sheets.Add
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
For i& = xlEdgeLeft To xlInsideVertical
  R.Borders(i&).LineStyle = xlContinuous
Next i&
Set R = Application.Union(S.Range(S.Cells(1, 2), S.Cells(UBound(T, 2), 2)), _
      S.Range(S.Cells(1, 4), S.Cells(UBound(T, 2), 4)))
R.NumberFormat = "m/d/yyyy"
Set R = S.Range(S.Cells(1, 3), S.Cells(UBound(T, 2), 3))
R = "au"
R.HorizontalAlignment = xlCenter
Rows(1).Insert
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(T, 1)))
R = Titres
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub