Macro to sort block of data

[henryg]

I regularly need to sort a block of data in reverse order - the columns are always the same but the number of rows changes as does the name of the workbook; always csv in my case. I have tried recording a macro but it is not generic, hard coding the name of the workbook and the size of the data block. I tried OpenAI but its solution fails every time.

The steps I use manually, starting at A1, are: autofit column A; create table with headers; goto F2 and add =Row(); select all data in block excluding headers by shift-end-down arrow (xlDown) & ctrl-shift- left arrow (xlToLeft); sort Z to A (cursor has remained in F2). Simple.

Recording a macro gives

Sub Macro4()
'
' Macro4 Macro
'

'
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$e$14"), , xlYes).Name = _
"Table1"
Range("F2").Select
Selection.FormulaR1C1 = "=ROW()"
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Columns("A:A").EntireColumn.AutoFit
ActiveWorkbook.Worksheets("GB").ListObjects( _
"Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("GB").ListObjects( _
"Table1").Sort.SortFields.Add2 Key:=Range("Table1[Column2]"), SortOn:= _
xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("GB").ListObjects( _
"Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

with the hard-coded name and range, while OpenAI gave me (which fails)

Sub DynamicSortMacro()
'
' DynamicSortMacro Macro
'

'
Dim ws As Worksheet
Dim tbl As ListObject
Dim lastRow As Long

' Set the worksheet where you want to apply the macro
Set ws = ThisWorkbook.Worksheets("Your_Worksheet_Name")

' Find the last row in the data block
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Add a ListObject (Table) to the specified range
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("$A$1:$E$" & lastRow), , xlYes)
tbl.Name = "Table1"

ws.Range("G2").FormulaR1C1 = "=ROW()"
ws.Range(ws.Range("G2"), ws.Range("G2").End(xlDown).End(xlToLeft)).Columns.AutoFit

' Apply sorting
With tbl.Sort.SortFields
.Clear
.Add2 Key:=tbl.ListColumns("Column2").Range, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With

With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

which gives "subscript out of range at "Set ws = ThisWorkbook.Worksheets("Your_Worksheet_Name")" which I can't get past.

Any help would be much appreciated.

[edit] it would be useful if the number of columns was non-specific too!

 

[henryg]

OK, I made the follow amendments to the code Alex came up with. See if this does what you want:

Sub TestSort()

    Dim ws As Worksheet
    Dim tbl As ListObject, rng As Range
    Dim lastRow As Long, lastCol As Long

    Set ws = Worksheets("GB")
    With ws
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'       Populate column F with counter and hard-code
        .Range("F1") = "Sort"
        .Range("F2:F" & lastRow).FormulaR1C1 = "=ROW()"
        .Range("F2:F" & lastRow).Value = .Range("F2:F" & lastRow).Value
      
        Set rng = .Range("A1").CurrentRegion.Resize(, 6)
        Set tbl = .ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.Name = "Table1"
    End With
  
    With tbl
        .Range.Columns.AutoFit
        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=tbl.ListColumns(6).Range, SortOn:= _
                xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

'   If you wish to delete column F at end, uncomment following line:
'   Columns("F:F").Delete Shift:=xlToLeft

End Sub

This worked great! Thank you so much.

BUT the worksheet name is still hard-coded, and I need it to be picked up from the workbook or, preferably, the current worksheet, which ever is easier as it will be different in every workbook/worksheet.

Also the data doesn't need to be formatted as a table, I just found it easier when I was trying to come up with a solution.

 

[Joe4]

Just try changing this line:

    Set ws = Worksheets("GB")

to this:

    Set ws = ActiveSheet

 

[henryg]

Just try changing this line:

    Set ws = Worksheets("GB")

to this:

    Set ws = ActiveSheet

PERFECT, PERFECT, PERFECT

 

[Joe4]

I added the update to the code below, so that this can be marked as the solution, as it really does not make sense to mark a post with just one line of code as the solution to your original question:

Sub TestSort()
' Amended code created by Alex Blankenburg

    Dim ws As Worksheet
    Dim tbl As ListObject, rng As Range
    Dim lastRow As Long, lastCol As Long

    Set ws = ActiveSheet
    With ws
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'       Populate column F with counter and hard-code
        .Range("F1") = "Sort"
        .Range("F2:F" & lastRow).FormulaR1C1 = "=ROW()"
        .Range("F2:F" & lastRow).Value = .Range("F2:F" & lastRow).Value
      
        Set rng = .Range("A1").CurrentRegion.Resize(, 6)
        Set tbl = .ListObjects.Add(xlSrcRange, rng, , xlYes)
        tbl.Name = "Table1"
    End With
  
    With tbl
        .Range.Columns.AutoFit
        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=tbl.ListColumns(6).Range, SortOn:= _
                xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

'   If you wish to delete column F at end, uncomment following line:
'   Columns("F:F").Delete Shift:=xlToLeft

End Sub

Also, credit due to Alex Blankenburg!
He came up with most of the code, I just made a few tweaks to it.

 

[henryg]

Apols. Heartfelt thanks to both Alex & Joe.

 

[Joe4]

Apols. Heartfelt thanks to both Alex & Joe.

No worries!
Glad we were to get a solution that works for you.