Macro to sort dat in range buy cell under clicked shape

[tonywatsonhelp]

Hi Everyone,
I need a macro that will sort ascending this range

"B7:Q1003"

no in row 7 the headers row i plan to have shapes you click to sort
so is it possible to make the sort column whatever column is under the shape i pressed?

please help if you can thanks
Tony

 

[cmowla]

Hi Tony,

So columns A-C , Rows 1-22 in your sheet looks something like this?

• And if you single left click on blue oval shape, you want it to short Ascending the values in range B8:B1003?
• And if you single left click on the red rectangular shape, you want it to short Ascending the values in range C8:C1003?

If so, yes, it can be done.

But you will have to assign all shapes to the following subroutine/macro (copy the sub name Sort_Column_Below_Shape_That_Is_Clicked_On) and then right click on each shape, select assign macro, paste the sub name into the search bar, and press enter.

But before doing this, please see the statement below the code block below!

Sub Sort_Column_Below_Shape_That_Is_Clicked_On()

Dim nameOfSheetTabIAmIn As String
nameOfSheetTabIAmIn = ActiveSheet.name

Dim firstRowToSort As Long
firstRowToSort = 8 'Hard coded in.

Dim columnLetter As String
Select Case Sheets(nameOfSheetTabIAmIn).Shapes(Application.Caller).name
    Case "Oval 1"
        columnLetter = "B"
    Case "Rounded Rectangle 2"
        columnLetter = "C"
    'Case "(Name of shape in column D)"
    '   columnLetter = "D"
'.
'.
'.
'.
    'Case "(Name of shape in column Q)"
    '   columnLetter = "Q"
    'Case Else

End Select

Dim lastRow As Long
lastRow = Sheets(nameOfSheetTabIAmIn).Range(columnLetter & firstRowToSort).End(xlDown).row
lastRow = 1003 'Delete (or comment out) this row if you want it to automatically find the last non-blank cell in this column!!

Dim rangeToSortAddress As String
rangeToSortAddress = columnLetter & firstRowToSort & ":" & columnLetter & lastRow

Sheets(nameOfSheetTabIAmIn).Range( _
Sheets(nameOfSheetTabIAmIn).Range(columnLetter & firstRowToSort), _
Sheets(nameOfSheetTabIAmIn).Range(columnLetter & lastRow) _
).Sort Key1:=Sheets(nameOfSheetTabIAmIn).Range(columnLetter & 1), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers

End Sub

To get the names of each of the shapes, you can select on the shape before you assign them to the macro with the following sub. So to get the name, left click on the shape once and then run the following line of code from the code window. Then put it in the Select Case statement with the appropriate corresponding column letter.

Sub GetNameOfShape()
MsgBox Selection.name
End Sub

But the natural question becomes . . . why don't you select range B7:Q1003 and press Ctrl T to make it an Excel Table (with filters) so that when you click on the arrow, you can sort it from there instead? (I guess you have a reason, but just mentioning this just in case!)

 

[tonywatsonhelp]

Thank you so much,
Cmowla, I'll have a play about with this now.
the reason i cant use the table ideas is two fold first for reasons i can not explain when i turn the range into a table the document starts to run supper slow and freezes up.
and more importantly its not just me using it and so a button saying sort seams so easy to use
anyway thanks for your help
Tony

 

[cmowla]

Thank you so much,
Cmowla, I'll have a play about with this now.
the reason i cant use the table ideas is two fold first for reasons i can not explain when i turn the range into a table the document starts to run supper slow and freezes up.
and more importantly its not just me using it and so a button saying sort seams so easy to use
anyway thanks for your help
Tony

If the Excel Table is messing things up, then how about you have it so that if you double click on cells B7:Q7 (just one at a time, of course), then it will do the sort.

Right click on the sheet tab name at the bottom and select "View Code". Copy the code below and paste. That's it! (You can color the cells with two color fills to make them each look different, if you want. (You can also make the border on the bottom and right of each cell THICK and lighter at the top and left to make them look more like buttons.)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If (Not Intersect(Target, Range("B7:Q7")) Is Nothing) And (Target.Cells.Count = 1) Then
    Cancel = True
    Dim nameOfSheetTabIAmIn As String
    nameOfSheetTabIAmIn = ActiveSheet.Name
    
    Dim firstRowToSort As Long
    firstRowToSort = 8 'Hard coded in.
    
    Dim columnLetter As String
    columnLetter = Split(Cells(1, Target.Column).Address, "$")(1)

    Dim lastRow As Long
    lastRow = Sheets(nameOfSheetTabIAmIn).Range(columnLetter & firstRowToSort).End(xlDown).Row
    lastRow = 1003 'Delete (or comment out) this row if you want it to automatically find the last non-blank cell in this column!!
    
    Dim rangeToSortAddress As String
    rangeToSortAddress = columnLetter & firstRowToSort & ":" & columnLetter & lastRow
    
    Sheets(nameOfSheetTabIAmIn).Range( _
    Sheets(nameOfSheetTabIAmIn).Range(columnLetter & firstRowToSort), _
    Sheets(nameOfSheetTabIAmIn).Range(columnLetter & lastRow) _
    ).Sort Key1:=Sheets(nameOfSheetTabIAmIn).Range(columnLetter & 1), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers

End If

End Sub

 

[tonywatsonhelp]

Thanks Cmowla, I tried this and it worked much better
thatnks for your help
Tony