VBA code to auto sort table based on any change within a specific column

[duteberta]

Given: Table Name = "MASTER"
Given: Column where change would trigger macro = "Status" (currently column 3 of table)

Given: Sort Macro =

Sub SortTable()

    Dim iSheet As Worksheet
    Dim iTable As ListObject
    Dim iColumn As Range
   
    Set iSheet = ActiveSheet
    Set iTable = iSheet.ListObjects("MASTER")
    Set iColumn1 = Range("MASTER[Status]")
    Set iColumn2 = Range("MASTER[CloseD]")
    Set iColumn3 = Range("MASTER[C1]")
   
    With iTable.Sort
   
      .SortFields.Clear
            .SortFields.Add Key:=iColumn1, Order:=xlAscending
            .SortFields.Add Key:=iColumn2, Order:=xlDescending
            .SortFields.Add Key:=iColumn3, Order:=xlAscending
            .Header = xlYes
            .Apply
        End With

End Sub

+++++++

Question: How do I write VBA code to trigger the above macro? I know the macro works because I've tested it. However I cannot get this trigger based on cell change in column 3.

Context: I already have another script running on the same worksheet that I'm worried is conflicting with what I'm attempting to do....

++++

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim tbl             As ListObject
    Dim rngCell         As Range
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    On Error Resume Next
    Set tbl = Target.Worksheet.ListObjects(1)
    If tbl Is Nothing Then Exit Sub
    If tbl.ListRows.Count = 0 Then Exit Sub
    
    Set rngCell = Application.Intersect(tbl.ListColumns("X").DataBodyRange, Target)
    If rngCell Is Nothing Then Exit Sub
    On Error GoTo 0
    
    tbl.ListColumns("X").DataBodyRange = ""
    rngCell.Value = 1
End Sub

++++

 

[duteberta]

Ok thanks- here is my currently working code in my worksheet - this is all working perfectly...

'Follow hyperlinks to hidden sheets

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim ShtName As String
ShtName = Left(Target.SubAddress, InStr(1, Target.SubAddress, "!") - 1)
Sheets(ShtName).Visible = xlSheetVisible
Sheets(ShtName).Select
End Sub

'Select entire table row by left-clicking in first column which selects that record for subsequest reporting

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim tbl             As ListObject
    Dim rngCell         As Range
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    On Error Resume Next
    Set tbl = Target.Worksheet.ListObjects(1)
    If tbl Is Nothing Then Exit Sub
    If tbl.ListRows.Count = 0 Then Exit Sub
    
    Set rngCell = Application.Intersect(tbl.ListColumns("X").DataBodyRange, Target)
    If rngCell Is Nothing Then Exit Sub
    On Error GoTo 0
    
    tbl.ListColumns("X").DataBodyRange = ""
    rngCell.Value = 1
End Sub

'Entire table row changes to VALUES after "SOLD" is selected from dropdown

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim rngCol1 As Range
    Dim rng2 As Range
    Dim LO As ListObject
    Dim lColCnt As Long
    Dim i As Long
    Dim v As Variant

    Set LO = Me.ListObjects(1)
    lColCnt = LO.ListColumns.Count

    Set rngCol1 = Intersect(Target, LO.Range.Columns(3))

    If Not rngCol1 Is Nothing Then
        With Application
            .EnableEvents = False
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With

        ReDim v(1 To lColCnt)

        For Each rng In rngCol1
            If LCase(rng.Value) = LCase("SOLD") Then
                i = 0

                'Remember the numerical formats of each column
                For Each rng2 In LO.ListRows(rng.Row - LO.Range.Row).Range
                    i = i + 1
                    v(i) = rng2.NumberFormat
                Next rng2

                '"paste" values
                rng.Resize(, lColCnt).Value = rng.Resize(, lColCnt).Value

                'Restore original formats of each column
                For i = 1 To lColCnt
                    LO.ListRows(rng.Row - LO.Range.Row).Range.Cells(1).Offset(, i - 1).NumberFormat = v(i)
                Next i
            End If
        Next rng

        With Application
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
        End With
    
    End If
    
   
End Sub

 

[duteberta]

Here is what I want to ADD this worksheet: (Triggers on any change in MASTER[Status] column)

'Auto sort table on change
Sub SortTable()

    Dim iSheet As Worksheet
    Dim iTable As ListObject
    Dim iColumn As Range

    
    Set iSheet = ActiveSheet
    Set iTable = iSheet.ListObjects("MASTER")
    Set iColumn1 = Range("MASTER[Status]")
    Set iColumn2 = Range("MASTER[CloseD]")
    Set iColumn3 = Range("MASTER[C1]")
    
    With iTable.Sort
    
      .SortFields.Clear
            .SortFields.Add Key:=iColumn1, Order:=xlAscending
            .SortFields.Add Key:=iColumn2, Order:=xlDescending
            .SortFields.Add Key:=iColumn3, Order:=xlAscending
            .Header = xlYes
            .Apply
        End With

End Sub

 

[duteberta]

I made a test workbook that ink only 36KB to just work on this issue if you want it. I just have no idea how to upload this to the forum.

 

[Peter_SSs]

here is my currently working code in my worksheet

Thanks for the code. Follow these steps to test with a copy of your workbook.

1. If it is still there, remove that very short Worksheet_Change code that I put in post #8
2. Add this one line (shown blue below towards the end) to your current longer Worksheet_Change code.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim rngCol1 As Range
    Dim rng2 As Range
    Dim LO As ListObject
    Dim lColCnt As Long
    Dim i As Long
    Dim v As Variant

    Set LO = Me.ListObjects(1)
    lColCnt = LO.ListColumns.Count

    Set rngCol1 = Intersect(Target, LO.Range.Columns(3))

    If Not rngCol1 Is Nothing Then
        With Application
            .EnableEvents = False
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With

        ReDim v(1 To lColCnt)

        For Each rng In rngCol1
            If LCase(rng.Value) = LCase("SOLD") Then
                i = 0

                'Remember the numerical formats of each column
                For Each rng2 In LO.ListRows(rng.Row - LO.Range.Row).Range
                    i = i + 1
                    v(i) = rng2.NumberFormat
                Next rng2

                '"paste" values
                rng.Resize(, lColCnt).Value = rng.Resize(, lColCnt).Value

                'Restore original formats of each column
                For i = 1 To lColCnt
                    LO.ListRows(rng.Row - LO.Range.Row).Range.Cells(1).Offset(, i - 1).NumberFormat = v(i)
                Next i
            End If
        Next rng
        SortTable
        With Application
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
        End With
        
    End If
    
End Sub

 

[duteberta]

Holy crap it worked! It was that simple ??!! How does it know to custom sort? Does it just remember the previous sort instructions? Anyway I am thrilled! Thank you so much!

 

[Peter_SSs]

How does it know to custom sort? Does it just remember the previous sort instructions?

No it doesn't just remember, it uses the SortTable code that you provided in post 1 and is still stored in your workbook.

 

[duteberta]

Oh I see- it refers to the macro I wrote that is in a Module. I get it. Sorry I'm new to this and trying to figure it out. Many thanks for your assistance!

 

[Peter_SSs]

it refers to the macro I wrote that is in a Module.

Correct, and your original Worksheet_Change code only proceeds if a change was made in that third column so the "trigger" has already been checked.

Many thanks for your assistance!

You're welcome.