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
)and then editing the table before U placed in the Word document? Anyways, I did kick around a method for that by adding the table to a listbox and then using some textboxes to change the listbox selections, but I'm not quite sure that's what U want or how U would want it presented in the document? In table format or something else? One thing at a time, do U have all of those sheet names? Dave
Reply With Quote
Good luck. Be Safe. Dave
