Better Way to

[Rishek]

I've cobbled this together using code kindly given to me here (http://www.vbaexpress.com/forum/showthread.php?59600-Extract-most-recent-quot-Header-quot-into-table), among other places.

I'm trying to extract the data from both "columns" of this document 19615 to an excel workbook.

Is there a more efficient way of doing this? Here's what I'm using:



Sub ExtractCoachings()
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
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(4)
For iRow = 2 To oTable.Rows.Count 'This block extracts the first "column"
If oTable.Rows(iRow).Cells.Count = 6 Then
Set oCell = oTable.Cell(iRow, 2).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, 3).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)
xlBook.sheets(1).Range("D" & NextRow) = "Coaching"
Next i
End If
End If
Next iRow
For iRow = 2 To oTable.Rows.Count 'This block extracts the second "column"
If oTable.Rows(iRow).Cells.Count = 6 Then
Set oCell = oTable.Cell(iRow, 5).Range
oCell.End = oCell.End - 1
If Len(Trim(oCell.Text)) > 0 Then
vName = Split(oCell.Text, ",")
Set oTime = oTable.Cell(iRow, 4).Range
oTime.End = oTime.End - 1
For i = 0 To UBound(vName)
Set oLocation = oTable.Cell(iRow, 6).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) = "Coaching" '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