active cell changes when sorted

[BobtBuilder]

I have a table and every time I add a row I would like it to dynamically sort by date but keep me on the activecell. But when I sort it brings me to the cell number i was originally on and not the one i was working on. The active cell changes number on sort.

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject
Set tbl = Me.ListObjects(1) ' Assuming your table is the first ListObject on the sheet

' Check if the changed cell is within the table
If Not Intersect(Target, tbl.ListColumns("Date").DataBodyRange) Is Nothing Then
' Disable events to prevent recursive triggering
Application.EnableEvents = False

' Store the address of the active cell
Dim activeCellAddress As String
activeCellAddress = ActiveCell.Address

' Sort the table based on the "Date" column in ascending order
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add Key:=tbl.ListColumns("Date").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending
tbl.Sort.Apply

' Re-enable events
Application.EnableEvents = True

' Return to the original active cell
Range(activeCellAddress).Select
End If
End Sub

Thank you

 

[Akuini]

1. In the table, is there any column with unique data?
2. Is the table start at column A?

 

[kevin9999]

What happens when you remove this line:
Range(activeCellAddress).Select

 

[Alex Blakenburg]

Give this a try, hopefully someone will come up with a better option.
This changes the font on the target cell and then uses find format to return to that cell.
Since Tables can get confused when formatting is not applied to the whole table column I opted to reset the font by applying the original font to the whole table column (databody).
If you do a fill down or paste it will go to the 1st item in the range updated.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngIntersect As Range
    Dim tbl As ListObject
    Set tbl = Me.ListObjects(1) ' Assuming your table is the first ListObject on the sheet
    Set rngIntersect = Intersect(Target, tbl.ListColumns("Date").DataBodyRange)

    ' Check if the changed cell is within the table
    If Not rngIntersect Is Nothing Then
    ' Disable events to prevent recursive triggering
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        
        ' Set up and apply search characteristic to the 1st selected cell in the Date column
        Dim origFnt As String, tmpFnt As String
        With rngIntersect.Cells(1)
            origFnt = .Font.Name
            tmpFnt = "Comic Sans MS"
            .Font.Name = tmpFnt
        End With

        ' Sort the table based on the "Date" column in ascending order
        tbl.Sort.SortFields.Clear
        tbl.Sort.SortFields.Add Key:=tbl.ListColumns("Date").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending
        tbl.Sort.Apply
        
        ' Find search characteristic applied to Target cell
        With Application.FindFormat
            .Clear
            .Font.Name = tmpFnt
        End With
        
        Dim origCell As Range
        With tbl.ListColumns("Date").DataBodyRange
            Set origCell = .Find(What:="*", SearchFormat:=True)
            .Font.Name = origFnt        ' Apply to whole column or table might get confused
        End With
        Application.FindFormat.Clear
        
        ' Activate original target cell, if multiple cells 1st cell in date column in target range
        origCell.Select

        ' Re-enable events
        Application.EnableEvents = True
        Application.ScreenUpdating = True

    End If
End Sub

 

[BobtBuilder]

1. In the table, is there any column with unique data?
2. Is the table start at column A?

Nothing is really unique and yes table starts in column a

 

[BobtBuilder]

What happens when you remove this line:
Range(activeCellAddress).Select

brings me to the top of the table

 

[Akuini]

Nothing is really unique and yes table starts in column a

Did you try @Alex Blakenburg macro?

 

[BobtBuilder]

Give this a try, hopefully someone will come up with a better option.
This changes the font on the target cell and then uses find format to return to that cell.
Since Tables can get confused when formatting is not applied to the whole table column I opted to reset the font by applying the original font to the whole table column (databody).
If you do a fill down or paste it will go to the 1st item in the range updated.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngIntersect As Range
    Dim tbl As ListObject
    Set tbl = Me.ListObjects(1) ' Assuming your table is the first ListObject on the sheet
    Set rngIntersect = Intersect(Target, tbl.ListColumns("Date").DataBodyRange)

    ' Check if the changed cell is within the table
    If Not rngIntersect Is Nothing Then
    ' Disable events to prevent recursive triggering
        Application.EnableEvents = False
        Application.ScreenUpdating = False
       
        ' Set up and apply search characteristic to the 1st selected cell in the Date column
        Dim origFnt As String, tmpFnt As String
        With rngIntersect.Cells(1)
            origFnt = .Font.Name
            tmpFnt = "Comic Sans MS"
            .Font.Name = tmpFnt
        End With

        ' Sort the table based on the "Date" column in ascending order
        tbl.Sort.SortFields.Clear
        tbl.Sort.SortFields.Add Key:=tbl.ListColumns("Date").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending
        tbl.Sort.Apply
       
        ' Find search characteristic applied to Target cell
        With Application.FindFormat
            .Clear
            .Font.Name = tmpFnt
        End With
       
        Dim origCell As Range
        With tbl.ListColumns("Date").DataBodyRange
            Set origCell = .Find(What:="*", SearchFormat:=True)
            .Font.Name = origFnt        ' Apply to whole column or table might get confused
        End With
        Application.FindFormat.Clear
       
        ' Activate original target cell, if multiple cells 1st cell in date column in target range
        origCell.Select

        ' Re-enable events
        Application.EnableEvents = True
        Application.ScreenUpdating = True

    End If
End Sub

That seemed to work. Thank you never thought about changing the font!

 

[Alex Blakenburg]

I needed to change a characteristic that moved with the sort and that was unlikely to be already in use to highlight certain rows.
I figured background colour and font colour might already be in use and borders don't move with the sort. Hence my choice of using Font.
Having been recently introduced to the Cell ID property I considered using it but to find it back the code would need to read every cell while with Font I could use the Find Method.
Thanks for letting us know it worked. Glad we could help.