Option Explicit
 
Sub Tst()
Dim LastRow As Long, i As Long
Dim LastCol As Long, k As Long
 
    LastRow = ShDepart.Range("A" & Rows.Count).End(xlUp).Row
    ShFinal.Cells.Clear
    Application.ScreenUpdating = False
    k = 1
 
    For i = 1 To LastRow
        LastCol = ShDepart.Range("IV" & i).End(xlToLeft).Column
        ShDepart.Range("A" & i & ":B" & i).Copy ShFinal.Range("A" & k & ":B" & k + LastCol - 3)
 
        ShDepart.Range("C" & i & ":" & NumCol2Lettre(LastCol) & i).Copy
        ShFinal.Range("C" & k).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 
        k = ShFinal.Range("C" & Rows.Count).End(xlUp).Row + 1
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    ShFinal.Activate
End Sub
 
Private Function NumCol2Lettre(ByVal NumCol As Long) As String
Dim i As Long, x As Long, s As String
    For i = 6 To 0 Step -1
        x = (26 ^ (i + 1) - 1) / 25 - 1
        If NumCol > x Then
            s = s & Chr(((NumCol - x - 1) \ 26 ^ i) Mod 26 + 65)
        End If
    Next i
    NumCol2Lettre = s
End Function