Comment reduire mille colonne à une seule?

Option Explicit

' constantes tableau origine
Const lidebFO As Long = 1
Const codebFO As Long = 1
' constantes tableau but
Const lidebFB As Long = 1
Const coFB As Long = 1

Public Sub ReduireEnUneColonne()
Dim liFO As Long, lifinFO As Long
Dim coFO As Long, cofinFO As Long
Dim liFB As Long
Dim s As String
  Application.ScreenUpdating = False
  With ActiveSheet
    ' dernière ligne/colonne feuill O
      lifinFO = .Cells(Rows.Count, codebFO).End(xlUp).Row
      cofinFO = .Cells(lidebFO, Columns.Count).End(xlToLeft).Column
    ' on y va
      liFB = lidebFB
      For coFO = codebFO To cofinFO
        For liFO = lidebFO To lifinFO
          .Cells(liFB, coFB) = .Cells(liFO, coFO)
          liFB = liFB + 1
        Next liFO
      Next coFO
  End With
  Application.ScreenUpdating = True
End Sub