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): 19695

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.