Excel: Sorting Multple Columns separately

Question

I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.

https://i.sstatic.net/N3HVE.png

What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.

I don't think there is a simple method for doing this, so I was thinking of 2 possible ways

1. I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.

or

2. Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.

I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.

However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.

Answer 1

Copy and Sort

• The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
• Adjust the values in the constants section.

Option Explicit

Sub copyAndSort()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "D1"
    Const yCols As String = "E:G"
    
    Const dFirst As String = "A1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim srg As Range
    Dim yrg As Range
    Dim rCount As Long
    Dim cCount As Long
    
    With sws.Range(sFirst)
        Dim rOff As Long: rOff = .Row - 1
        Dim sCell As Range
        Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If sCell Is Nothing Then Exit Sub
        rCount = sCell.Row - rOff
        Set srg = .Resize(rCount)
        Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
        cCount = yrg.Columns.Count
    End With
    
    Dim sData As Variant: sData = srg.Value
    ReDim Preserve sData(1 To rCount, 1 To 2)
    Dim yData As Variant: yData = yrg.Value
    
    Dim Result As Variant: ReDim Result(1 To cCount)
    
    Dim c As Long, r As Long
    
    For c = 1 To cCount
        Result(c) = sData
        For r = 1 To rCount
            Result(c)(r, 2) = yData(r, c)
        Next r
    Next c
    Erase yData
    Erase sData
    
    Dim dws As Worksheet
    Dim drg As Range
    Dim dName As String
    
    Application.ScreenUpdating = False
    
    For c = 1 To cCount
        dName = Result(c)(1, 2)
        On Error Resume Next
        Set dws = Nothing
        Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If Not dws Is Nothing Then
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        End If
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = dName
        Set drg = dws.Range(dFirst).Resize(rCount, 2)
        drg.Value = Result(c)
        drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
    Next c

    wb.Save
        
    Application.ScreenUpdating = True
        
End Sub