Cacher is the code snippet organizer for pro developers

Sub FullTableSorter()

'On Error Resume Next

Dim rng, Headerx As Range
Dim nrow, ncol, i, j As Integer
'Dim oldsheet, newsheet As Worksheet
Dim orignam As String
Dim newnam As String

orignam = ActiveSheet.Name
Set rng = Application.InputBox("Please select source table area (include headers)", "Source table", Default:=Selection.Address, Type:=8)
Debug.Print "Original Worksheet Name: " & orignam

If SheetExists("Ranked_Full") Then
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "RFull" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")
    newnam = "RFull" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")
Else
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Ranked_Full"
    newnam = "Ranked_Full"
End If

'Set newsheet = ActiveWorkbook.Sheets("Ranked")

nrow = rng.Rows.Count
ncol = rng.Columns.Count

Set Headerx = Range(rng.Cells(1, 1), rng.Cells(1, ncol))

ActiveSheet.AutoFilterMode = False
Headerx.AutoFilter

'MsgBox Headerx.Address
'MsgBox Rng.Cells(1, 2).Address
'MsgBox Rng.Cells(nrow, 2).Address

For i = 2 To ncol
    j = (i - 1) * 2 'Column for output
    ActiveWorkbook.Worksheets(orignam).AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(orignam).AutoFilter.Sort.SortFields.Add Key:=Range(rng.Cells(1, i), rng.Cells(nrow, i)), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    With Worksheets(orignam).AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets(orignam).Range(rng.Cells(1, 1), rng.Cells(nrow, 1)).Copy
    ActiveWorkbook.Worksheets(newnam).Range(Cells(1, j), Cells(nrow, j)).PasteSpecial (xlPasteValues)
    
    ActiveWorkbook.Worksheets(orignam).Range(rng.Cells(1, i), rng.Cells(nrow, i)).Copy
    ActiveWorkbook.Worksheets(newnam).Range(Cells(1, j + 1), Cells(nrow, j + 1)).PasteSpecial (xlPasteValues)
    
    ActiveWorkbook.Worksheets(orignam).Range(rng.Cells(1, i), rng.Cells(1, i)).Copy
    ActiveWorkbook.Worksheets(newnam).Range(Cells(1, j), Cells(1, j)).PasteSpecial (xlPasteValues)
Next
        
End Sub

Function SheetExists(sheetName As String, Optional Wb As Workbook) As Boolean
    If Wb Is Nothing Then Set Wb = ThisWorkbook
    On Error Resume Next
    SheetExists = (LCase(Wb.Sheets(sheetName).Name) = LCase(sheetName))
    On Error GoTo 0
Exit Function
End Function