Sorry for the slow reply, Dave - VBA Express Forum has been playing up for me today.

Many thanks for this latest code!

I do have to run a couple of Macros from Excel to do some tidying and arranging. You're not going to like me, but yes, my word document could have from one to four of these tables, depending on the user's requirement.

My Macros always ensure that data is in cell A1, but will require my macros. These are as follows:-

First for Markers (& Markers1)

Sub Markers()

    ' Check for cells in column D that contain 'To'
    ' If any cells do then delete column

    Dim Cell   As Range, ws As Worksheet

    Set ws = Sheets("Markers")
    
    For Each Cell In ws.Range("$D:$D")
        Cell.Value = "To"
        Cell.EntireColumn.Delete
    Next Cell
    
    ' Format date in column C
    Range("$C:$C").NumberFormat = "dd/mm/yyyy"
    
    ' Delete first three rows
    Sheets("Markers").Range("$1:$3").EntireRow.Delete
    
    ' Sort Markers
    Dim rData       As Range, rData1 As Range, rData2 As Range
    Dim r           As Long, i As Long, iLastSort As String
    Dim arySorts    As Variant
    Dim sLastSort   As String
    
    arySorts = Array("Checked", "Ignored", "Important", "Untested", "Trial") ' starts at 0
    
    Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
    Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
    
    Application.AddCustomList ListArray:=arySorts
    
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Application.CustomListCount
        .SortFields.Add Key:=rData1.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
        .SetRange rData
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        .SortFields.Clear
    End With
    
    Set rData2 = Nothing
    With rData
        
        'see which last sort is in data
        For i = UBound(arySorts) To LBound(arySorts) Step -1
            iLastSort = -1
            On Error Resume Next
            iLastSort = Application.WorksheetFunction.Match(arySorts(i), Application.WorksheetFunction.Index(rData, 0, 2), 0)
            On Error GoTo 0
            
            'found custom sort value
            If iLastSort > -1 Then
                sLastSort = LCase(arySorts(i))
                Exit For
            End If
        Next i
    End With
    
    'custom sort value found
    If Len(sLastSort) > 0 Then
        
        With rData
            For r = .Rows.Count To 3 Step -1
                If LCase(.Cells(r, 2).Value) = sLastSort Then
                    Set rData2 = .Cells(r + 1, 1)
                    Set rData2 = Range(rData2, rData2.End(xlDown).End(xlToRight))
                    Exit For
                End If
            Next
        End With
        
        'MsgBox rData2.Address
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rData2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
            .SetRange rData2
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            .SortFields.Clear
        End With
        
    End If
    
    Application.DeleteCustomList ListNum:=Application.CustomListCount
     
    ' Delete first column
    Sheets("Markers").Range("$A:$A").EntireColumn.Delete
    
End Sub
The second for Person (& Person1)

Option Explicit
Sub Triage()

    ' Triage Macro

    'Delete any row containing the words 'Z INFORMATION SHARING' in column D
    Dim i           As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If InStr(Cells(i, 4), "Z INFORMATION SHARING") Then
            'If InStr(Cells(i, 4), "Z INFORMATION SHARING") Or InStr(Cells(i, 4), "Abcdef") Then
            Rows(i).Delete
        End If
    Next
    
    
    'Perform the basic editing
    'Delete first column
    
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    
    ' Find and remove all instances of [O]
    
    Columns("B:B").Select
    Selection.Replace What:=" [O]", Replacement:="", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=False
    
    'Format date column
    
    Range("$D:$D").NumberFormat = "dd/mm/yyyy"
    
    'Delete columns not required
    
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-1
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    
    'Delete all rows with a date older than eighteen months
    Application.ScreenUpdating = False
    ActiveSheet.AutoFilterMode = False
    Dim FilterRange As Range, myDate As Date
    myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
    Set FilterRange = _
        Range("D:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
    On Error Resume Next
    With FilterRange
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
    End With
    Err.Clear
    Set FilterRange = Nothing
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    
    'Select all remaining cells with data in them
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
End Sub