Cacher is the code snippet organizer for pro developers

Sub FullTableSorterExpanded()

'On Error Resume Next

Dim rng, Headerx As Range
Dim nrow, ncol, i, j As Integer
Dim orignam, newnam, newnam2 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

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

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

ActiveSheet.AutoFilterMode = False
Headerx.AutoFilter

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

If SheetExists("Ranked_Per") Then
    Worksheets(newnam).Copy After:=Worksheets(newnam)
    newnam2 = "RPer" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")
    ActiveSheet.Name = newnam2
  
Else
    Worksheets(newnam).Copy After:=Worksheets(newnam)
    newnam2 = "RPer" & Format(Date, "dd-mm-yy") & "@" & Format(Time, "hhmmss")
    ActiveSheet.Name = newnam2
End If

'Debug.Print i
'Debug.Print j
'Debug.Print ncol
'Debug.Print nrow

'j is the number of output columns in the Full Filter table

Dim k, m As Long

For i = 1 To j / 2
    k = (i * 2) - 1 'Column for input
    For m = 2 To nrow
        ActiveWorkbook.Worksheets(newnam2).Cells(nrow + m, i + 1).Value = Bracketer(ActiveWorkbook.Worksheets(newnam2).Cells(m, k + 1), ActiveWorkbook.Worksheets(newnam2).Cells(m, k + 2))
    Next
Next




For i = 1 To j / 2
 k = (i * 2) - 1
 Cells(nrow + 1, i + 1).Value = Cells(1, k + 1).Value
 Debug.Print i
 Debug.Print j
 Debug.Print k
Next


'Cells(nrow + 1, j / 2).Value = Cells(1, j / 2).Value
         
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

Function Bracketer(a, b) As String
    Dim c As String
    c = Format(b, "0%")
    Bracketer = a & " (" & c & ")"
    
End Function