Quote Originally Posted by gmayor View Post
The following should do the trick and leaves the original document unchanged (but closed).
Option Explicit

Sub SplitToTable()
Dim oSource As Document
Dim oTarget As Document
Dim oTable As Table
Dim oRow As Row
Dim oRng As Range
Dim sText As String
Dim oCell As Range
Dim i As Long
     'Assign a variable name to the document
    Set oSource = ActiveDocument
    'Save the document (before changes are made to it)
    oSource.Save
    'Open a new document
    Set oTarget = Documents.Add
    'Create a table in that document and name the header row cells
    Set oTable = oTarget.Tables.Add(oTarget.Range, 1, 2)
    oTable.Rows(1).Cells(1).Range.Text = "ID"
    oTable.Rows(1).Cells(2).Range.Text = "Text"
    'Set a range to the original document
    Set oRng = oSource.Range
    'Remove duplicated paragraph breaks
    With oRng.Find
        Do While .Execute(FindText:="^13{1,}", MatchWildcards:=True)
            oRng.Text = vbCr
        Loop
    End With
    'Reset a range to the original document
    Set oRng = oSource.Range
    'Locate the ID text
    With oRng.Find
        Do While .Execute(FindText:="[A-Z]{3,}[0-9]{3,}", MatchWildcards:=True)
            On Error GoTo lbl_Exit
            'Move the end of the range to the "End" marker
            Do Until oRng.Next.Words(1) = "End" Or _
               oRng.End = oSource.Range.End
                oRng.MoveEnd wdWord
            Loop
            'Include the "End" marker in the range
            oRng.End = oRng.End + 3
            'Add a row to the table
            oTable.Rows.Add
            'Set a variable name to the last row of the table
            Set oRow = oTable.Rows.Last
            'Fill the first cell in the row with the ID text
            oRow.Cells(1).Range.Text = Split(oRng.Text, vbCr)(0)
            'Clear the sText string variable
            sText = ""
            'Add the remaining text to the string
            For i = 2 To oRng.Paragraphs.Count
                sText = sText & oRng.Paragraphs(i).Range.Text
            Next i
            'Remove any paragraph breaks from the string
            sText = Replace(sText, Chr(13), " ")
            'Remove any double spaces from the string
            sText = Replace(sText, "  ", " ")
            'Add the string to the second cell of the last row
            oRow.Cells(2).Range.Text = sText
            'Collapse the range to its end
            oRng.Collapse 0
            'And go round again
        Loop
    End With
    'Close the original document without recording the changes
    oSource.Close 0
lbl_Exit:
    Exit Sub
End Sub

Is there a way to modify the code so that instead of copying whole sentence, it picks only the next word??
for example:
"Scheme : LA172 Last Rephased on : 29-10-2001"

If i search for Scheme, it should give output as only LA172 not the whole sentence. I want it to run it for 6 different values and place the output in 6 different cell of same excel sheet. How to define total number of characters to be copied?