1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
| Sub TRANSPOSE()
Dim Ws As Worksheet, Ws2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("#TempSheet#").Delete
On Error GoTo 0
Worksheets.Add.Name = "#TempSheet#"
Set Ws2 = Worksheets("#TempSheet#")
For Each Ws In Worksheets
If Ws.Name <> "#TempSheet#" Then
Ws2.Cells.Clear
Ws.UsedRange.Copy
Ws2.Range("A1").PasteSpecial TRANSPOSE:=True
Ws.Cells.Clear
Ws2.UsedRange.Copy Ws.Range("A1")
End If
Next Ws
Ws2.Delete
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub |
Partager