Extract most recent "Header" into table

[Rishek]

So I have the following document:

19322

To Which I apply the following Macro (thanks to gmayor):


Sub ExtractNameTime()
Dim xlapp As Object
Dim xlBook As Object
Dim NextRow As Long
Dim oTable As Table
Dim oCell As Range, oTime As Range
Dim oLocation As Range, oEvent As Range
Dim iRow As Integer, i As Integer
Dim vName As Variant
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlBook = xlapp.Workbooks.Add
xlapp.Visible = True
xlBook.Sheets(1).Range("A1") = "Name"
xlBook.Sheets(1).Range("B1") = "Time"
xlBook.Sheets(1).Range("C1") = "Location"
xlBook.Sheets(1).Range("D1") = "Event"


Set oTable = ActiveDocument.Tables(1)
For iRow = 2 To oTable.Rows.Count
If oTable.Rows(iRow).Cells.Count = 4 Then
Set oCell = oTable.Cell(iRow, 3).Range
oCell.End = oCell.End - 1
If Len(Trim(oCell.Text)) > 0 Then
vName = Split(oCell.Text, ",")
Set oTime = oTable.Cell(iRow, 1).Range
oTime.End = oTime.End - 1
For i = 0 To UBound(vName)
Set oEvent = oTable.Cell(iRow, 2).Range 'The cell to process
oEvent.End = oEvent.End - 1 'Remove the cell end character from the range
Set oLocation = oTable.Cell(iRow, 4).Range
oLocation.End = oLocation.End - 1
NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
xlBook.Sheets(1).Range("A" & NextRow) = Trim(vName(i))
xlBook.Sheets(1).Range("B" & NextRow) = Trim(oTime.Text)
xlBook.Sheets(1).Range("C" & NextRow) = Trim(oLocation.Text) 'Add the location
xlBook.Sheets(1).Range("D" & NextRow) = Trim(oEvent.Text) 'Add the event
Next i
End If
End If
Next iRow
xlBook.Sheets(1).UsedRange.Columns.AutoFit
lbl_Exit:
Set xlapp = Nothing
Set xlBook = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oTime = Nothing
Set vName = Nothing
Exit Sub
End Sub


Sub FormatToExtract()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "\(*\)"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "^p"
.Replacement.Text = ", "
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "["
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "]"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = " ,"
.Replacement.Text = ","
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = ", *"
.Replacement.Text = "*"
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "\*(*)\*"
.Replacement.Text = ""
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With


End Sub

This works very well, but I've realized that the values extracted as oEvent are not super useful to me. I would prefer to extract the name of the show that appears (The Music Man, Hamlet, etc) in each box of the table and list that instead. How do I do that?


Set oEvent = oTable.Cell(iRow, 2).Range 'The cell to process
oEvent.End = oEvent.End - 1 'Remove the cell end character from the range

[mdmackillop]

Word macros are not my forte, so check the results carefully. Hopefully this gets the event name and will also open the attached Excel Template containing the further processing code.
The TimeSplit code should run automatically then stop, allowing for missing time data to be entered prior to running the Schedules code (which will otherwise fail)

Edit: Code modified to insert Date into cell B1 for use in Excel macros. It would be more robust to have the Header of the document in a table of two cells, rather than analysing the text value of the first paragraph.



Sub ExtractNameTime()
Dim xlapp As Object
Dim xlBook As Object
Dim NextRow As Long
Dim oTable As Table
Dim oCell As Range, oTime As Range, eCell As Range
Dim oLocation As Range, oEvent As Range
Dim iRow As Integer, i As Integer
Dim vName As Variant
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@ Dim StrName As String
Dim SaveName As String
Dim x As String
Dim Dt

'Get date Dt = Trim(Split(ActiveDocument.Paragraphs(1).Range, vbTab)(3))
StrName = "C:\VBAX\Schedule.xltm" 'Change to suit
SaveName = "C:\VBAX\Schedule " & Format(CDate(Split(Dt, ",")(1)), "d_mmm") 'Change to suit
'Delete existing if required
x = SaveName & ".xlsm"
If Len(Dir(x)) > 0 Then Kill x

On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'Open Excel
Set xlBook = xlapp.Workbooks.Open(StrName)
xlapp.Visible = True
xlBook.SaveAs SaveName, 52 'Macro enabled workbook

xlBook.Sheets(1).Range("A1") = "Name"
xlBook.Sheets(1).Range("B1") = CDate(Split(Dt, ",")(1))
xlBook.Sheets(1).Range("B1").NumberFormat = "ddd d mmmm"
xlBook.Sheets(1).Range("C1") = "Location"
xlBook.Sheets(1).Range("D1") = "Event"

Set oTable = ActiveDocument.Tables(1)
For iRow = 2 To oTable.Rows.Count
If oTable.Rows(iRow).Cells.Count = 1 Then
Set eCell = oTable.Cell(iRow, 1).Range
Set oEvent = eCell 'The cell to process
oEvent.End = oEvent.End - 1 'Remove the cell end character from the range
End If

If oTable.Rows(iRow).Cells.Count = 4 Then
Set oCell = oTable.Cell(iRow, 3).Range
oCell.End = oCell.End - 1
If Len(Trim(oCell.Text)) > 0 Then
vName = Split(oCell.Text, ",")
Set oTime = oTable.Cell(iRow, 1).Range
oTime.End = oTime.End - 1
For i = 0 To UBound(vName)

Set oLocation = oTable.Cell(iRow, 4).Range
oLocation.End = oLocation.End - 1
NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
xlBook.Sheets(1).Range("A" & NextRow) = Trim(vName(i))
xlBook.Sheets(1).Range("B" & NextRow) = Trim(oTime.Text)
xlBook.Sheets(1).Range("C" & NextRow) = Trim(oLocation.Text) 'Add the location
xlBook.Sheets(1).Range("D" & NextRow) = Trim(oEvent.Text) 'Add the event
Next i
End If
End If
Next iRow
xlBook.Sheets(1).UsedRange.Columns.AutoFit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
xlapp.Run "TimeSplit"

Application.WindowState = wdWindowStateMinimize
lbl_Exit:
Set xlapp = Nothing
Set xlBook = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oTime = Nothing
Set vName = Nothing
Exit Sub
End Sub

Sub FormatToExtract()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "\(*\)"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "^p"
.Replacement.Text = ", "
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "["
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "]"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = " ,"
.Replacement.Text = ","
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = ", *"
.Replacement.Text = "*"
.Execute Replace:=wdReplaceAll
Set oRng = ActiveDocument.Range
.Text = "\*(*)\*"
.Replacement.Text = ""
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End Sub