Sub TRP()
Range("A1:FH5003").Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.[A1].PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub

Sub TRP()

Dim Arr(), i As Long, j As Long

Range("A1:FH5003").Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.[A1].PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Arr() = ActiveSheet.UsedRange.Value
For i = 1 To UBound(Arr, 1)
For j = 1 To UBound(Arr, 2)
Arr(i, j) = UCase(Arr(i, j))
Next j
Next i
ActiveSheet.UsedRange.Value = Arr()

End Sub

Sub test()
Dim c As Range, i As Long
For Each c In Selection
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[P, Q, R, S]" Then
c.Characters(Start:=i, Length:=1).Font.Color = -16776961
End If
Next i
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[I, J, K, L, M, N, O]" Then
c.Characters(Start:=i, Length:=1).Font.Color = RGB(0, 0, 0)
End If
Next i
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[A, B, C, D]" Then
c.Characters(Start:=i, Length:=1).Font.Color = RGB(30, 144, 225)
End If
Next i
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[T, U, V, W, X, Y, ]" Then
c.Characters(Start:=i, Length:=1).Font.Color = RGB(0, 128, 128)
End If
Next i
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[Z, a, b]" Then
c.Characters(Start:=i, Length:=1).Font.Color = RGB(0, 255, 0)
End If
Next i
For i = 1 To Len(c)
If Mid$(c, i, 1) Like "[E, F, G, H]" Then
c.Characters(Start:=i, Length:=1).Font.Color = RGB(0, 0, 0)
End If


Next i
Next c
End Sub