Sub Macro1()
Dim ws As Worksheet, i As String
Application.ScreenUpdating = False
Cells.Delete
i = ActiveSheet.Name
For Each ws In Worksheets
If ws.Name <> "TR" Then
Sheets(ws.Name).Activate
Range("a1:E" & Range("a65536").End(xlUp).Row).Copy _
Destination:=Sheets("TR").[XFD3].End(xlToLeft).Offset(0, 1)
End If: Next ws: Sheets(i).Select: [a1].Select: Columns("A:E").ColumnWidth = 18
End Sub