Option Explicit
Dim nlm&, lg2&
Private Sub Job(i%)
Dim coID%, dlg&
With Worksheets(i)
coID = .Cells(2, Columns.Count).End(1).Column - 6
dlg = .Cells(2, coID).End(4).Row
.Cells(2, coID).Resize(dlg - 1, 11).Copy Cells(lg2, 1)
lg2 = lg2 + dlg - 1
dlg = .Cells(nlm, coID).End(3).Row
.Cells(dlg, coID).Resize(, 11).Copy Cells(lg2, 1)
Cells(lg2, 1).Resize(, 11).Borders.LineStyle = 1
lg2 = lg2 + 1
End With
End Sub
Sub CpyTbl()
On Error Resume Next
Dim Ws As Worksheet, lig&, k&, n%, p%: n = Worksheets.Count
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
For Each Ws In Application.Worksheets
If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then Ws.Delete
Next Ws
For p = 1 To n
With Worksheets(p)
.Cells.UnMerge: k = .[A65536].End(3).Row
For lig = k To 1 Step -1
If Application.CountA(.Rows(lig)) = 0 Then .Rows(lig).Delete 3
Next lig
End With
Next p
Application.DisplayAlerts = -1
Sheets.Add Before:=Worksheets(1)
Sheets(1).Name = "PASTE" '
Dim i%: Application.ScreenUpdating = 0
Worksheets("PASTE").Select: Cells.Clear
nlm = Rows.Count: lg2 = Cells(nlm, 1).End(3).Row + 1
If lg2 = 2 And [A1] = "" Then lg2 = lg2 - 1
For i = 2 To Worksheets.Count: Job i: Next i
Cells(lg2 + 1, 1).Select: Application.CutCopyMode = 0
MsgBox ("MTO ESTABLISHED !")
End Sub