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 |