Eliminate Split While Extracting Entries

[Rishek]

I'm using a modified macro from gmayor to extract some data from a table (here's a sample): Coaching Table.docx

Here's the macro I'm using:

Sub ExtractLocTime()
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
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") = "Location"
xlBook.Sheets(1).Range("B1") = "Time"
xlBook.Sheets(1).Range("C1") = "Event"
 
    Set oTable = ActiveDocument.Tables(1)
    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(oLocation.Text)
                    xlBook.Sheets(1).Range("B" & NextRow) = Trim(oTime.Text)
                    xlBook.Sheets(1).Range("C" & NextRow) = "CO"
                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(oLocation.Text)
                    xlBook.Sheets(1).Range("B" & NextRow) = Trim(oTime.Text)
                    xlBook.Sheets(1).Range("C" & NextRow) = "CO" '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

The issue is that the code vName = Split(oCell.Text, ",") is causing some entries to be extracted twice. I have solved this by replacing the code with Split(oCell.Text, "%") which works because there aren't any % signs in that box, but I was wondering if there was a more elegant way to do this. I have tried just deleting the Split(), but it doesn't seem to like that.

Not urgent, would just help me understand the code a little bit better.

[gmaxey]

I don't really know what the final result is supposed to look like but the reason some things are done twice is because your are doing something

For x = 0 to Y (Some number of times) e.g

Sub Demo()
Dim varDemo
Dim lngIndex As Long
  'When you split a string delimited by a comma ...
  varDemo = Split("A,B,C,D", ",")
  'You get x number of sub-strings
  MsgBox UBound(varDemo)
  For lngIndex = 0 To UBound(varDemo)
    MsgBox varDemo(lngIndex)
  Next
End Sub

Try:

Option Explicit

Sub ExtractLocTime()
Dim xlapp As Object, xlBook As Object
Dim NextRow As Long
Dim oTable As Table
Dim iRow As Integer, i As Integer
  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") = "Location"
  xlBook.Sheets(1).Range("B1") = "Time"
  xlBook.Sheets(1).Range("C1") = "Event"
  Set oTable = ActiveDocument.Tables(1)
  For iRow = 2 To oTable.Rows.Count 'This block extracts the first "column"
    If oTable.Rows(iRow).Cells.Count = 6 Then
      If Len(Trim(fcnCellText(oTable.Cell(iRow, 2)))) > 0 Then
        NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
        xlBook.Sheets(1).Range("A" & NextRow) = Trim(fcnCellText(oTable.Cell(iRow, 3)))
        xlBook.Sheets(1).Range("B" & NextRow) = Trim(fcnCellText(oTable.Cell(iRow, 1)))
        xlBook.Sheets(1).Range("C" & NextRow) = "CO"
      End If
      If Len(Trim(fcnCellText(oTable.Cell(iRow, 5)))) > 0 Then
        NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
        xlBook.Sheets(1).Range("A" & NextRow) = Trim(fcnCellText(oTable.Cell(iRow, 6)))
        xlBook.Sheets(1).Range("B" & NextRow) = Trim(fcnCellText(oTable.Cell(iRow, 4)))
        xlBook.Sheets(1).Range("C" & NextRow) = "CO"
      End If
    End If
  Next iRow
  xlBook.Sheets(1).UsedRange.Columns.AutoFit
lbl_Exit:
  Set xlapp = Nothing: Set xlBook = Nothing: Set oTable = Nothing
  Exit Sub
End Sub

Function fcnCellText(oCell As Cell) As String
  fcnCellText = Left(oCell.Range.Text, Len(oCell.Range.Text) - 2)
lbl_Exit:
  Exit Function
End Function

[Rishek]

Cheers! Helpful to know about the lngIndex stuff. That was what I was hoping to figure out.