VBA Word - Copy Strings into a Table

Hello to all,

I hope every one is starting their Friday off well .:hi:

I have come back to ask for help, on a range paragraph - table problem as well.


I have lots of paragraphs - they all start similarly::


---------------------------------------------

DNS345

Video provides a powerful way to help you prove your point. When you click Online Video,

End


DNS732

Video provides a powerful way to help you prove your point. When you click Online Video,
text text text text text text text text text text text text
End

---------------------------------------------


I need to move these into a table in a new document.

So I will end up with

Column 1 -ID | Column 2 - Text

DNS345 | Video provides a powerful way to help you prove your point.When you click Online Video, End


I am very sad :crying: I hoped the macro recorder would help me solve this, but there is not much hope of that, its a good as a useless teapot.


I tried to code a basic version - alas it's not very attractive be warned

Code:

---


Sub CopyParagraphTable

Dim oRng As Range, aTable As Range
 
    Dim StringPara As String
    Set rng = ActiveDocument.Content
    With rng.Find

        .ClearFormatting
        .MatchWildcards = True
        .Wrap = wdFindStop

        .Text = "[A-Z0-9]{1,}"

        Do While .Execute

            StringPara = StringPara & vbCr & rng.Text        '  END  here
        Loop
    End With

' Move  strings range now into table

With aTable.Tables(1)

  Set aTable = oRng.Paragraphs(1).Range
  'Put this into first column

  Number(aTable.Cell(1, 1).Range.Words(1).Text) Then
                Set oRng = oTable.Range
                Do While
 
    (aTable.Cell(1, 2).Range.StringPara(2).Text)

                    aTable.End = aTable.Next.End
                Loop
                oRng.End = aTable.End

'and now stuck

' Need to add document source  and copy to table

---

So to Recap

All the text starts with DNS and ends with - END

DNS goes into Column 1 - Content in Column 2 For each range.


I would be so grateful for the kindness of the code philanthropists to help solve this problem. As I don't know what to do, the most advanced help I received from the VBE editor was a ground breaking Selection.Copy and nothing else.

thank you so much for your time, expertise and helping me

I am very grateful :)

Saphire

The following should do the trick and leaves the original document unchanged (but closed).

Code:

---

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

---

Hello Graham,

and happy new year.

How did you do this? :biggrin:

I love it! - it's exquisitely awesome!

You are too good to me.

I tried the wild card regex search to find the DNS -but how was I supposed to find the ensuing range? Some of them are very long ranges.

As you can see I butchered the predecessor code, and did it lash out at me like a snake. :whip

I have long documents that were giving me the shivers.

Also I just can't deal with copy and pasting :crying:.

After 10 paragraphs copy and pasting - long ranges - That's a lot of dragging and selecting to do and thanks to my introduction to the VBA I knew there must be a better way.



This is dazzling magnificent.

I will use it every day.


I am happy as Larry as they say - my Friday is perfect.

Thank you soooooo much :biggrin:


I hope you will have a great weekend

Saphire

xo

:wavey:

This is Solved

Quote:

---

Originally Posted by gmayor

The following should do the trick and leaves the original document unchanged (but closed).

Code:

---

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?

The original macro works with a Word table. To extract just the 'Word' after Scheme, see below. It wouldn't be much of a stretach to output to a worksheet rather than a Word table.

Code:

---

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, 1)
    oTable.Rows(1).Cells(1).Range.Text = "ID"
    'Set a range to the original document
    Set oRng = oSource.Range
    'Locate the ID text
    With oRng.Find
        Do While .Execute(FindText:="Scheme : ", MatchCase:=True)
            On Error GoTo lbl_Exit
            oRng.End = oRng.Next.Words(1).End
            oRng.Start = oRng.Words.Last.Start
            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 = oRng.Text
            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

---

Quote:

---

Originally Posted by gmayor

The original macro works with a Word table. To extract just the 'Word' after Scheme, see below. It wouldn't be much of a stretach to output to a worksheet rather than a Word table.

Code:

---

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, 1)
    oTable.Rows(1).Cells(1).Range.Text = "ID"
    'Set a range to the original document
    Set oRng = oSource.Range
    'Locate the ID text
    With oRng.Find
        Do While .Execute(FindText:="Scheme : ", MatchCase:=True)
            On Error GoTo lbl_Exit
            oRng.End = oRng.Next.Words(1).End
            oRng.Start = oRng.Words.Last.Start
            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 = oRng.Text
            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 it possible to extract six different values from data and define the range also to specify how many characters it has to pick while omitting any tabs or spaces. Sample data is pasted below.
sample is as pasted below:

Mr.XYZ

--------------------------------------------------------------------------------------------------------------------------------

Account Number : 01180600999999 Currency : INDIAN RUPEE Account Balance 66,177.00Dr

Scheme : LA001 Last Rephased on : 07-03-2000 Schedule Number : 01 Interest Liability 0

--------------------------------------------------------------------------------------------------------------------------------

Flow Flow Date of Demand Amount Last Adjust- Amount Adjusted Due Date Days
Type Description Demand ment Date Overdue
--------------------------------------------------------------------------------------------------------------------------------
PRDEM PRINCIPAL DEMAND 07-04-2001 25,000.00 0.00 08-04-2001 5399
INDEM INTEREST DEMAND 17-11-2007 41,177.00 0.00 19-11-2007 2983

--------------------------------------------------------------------------------------------------------------------------------
TOTAL OVERDUE : 66,177.00

--------------------------------------------------------------------------------------------------------------------------------

I need to extract the data typed in bold letters and paste into another excel file in 6 different columns. The spaces are very random after each word. Its not possible to count spaces or tabs as its different for every data set. Can we preapre a single code to extract all 6 parameters from the file?

The following should work. Write the strings to your worksheet

Code:

---

Sub ExtractData(oDoc As Document)
Dim strName As String
Dim strAcc As String
Dim strBalance As String
Dim strScheme As String
Dim strDate As String
Dim strTotal As String
Dim oRng As Range
Dim oPara As Paragraph

    Set oRng = oDoc.Range
    For Each oPara In oRng.Paragraphs
        If Len(oPara.Range) > 1 Then
            strName = oPara.Range.Text
            If InStr(1, strName, Chr(46)) > 0 Then
                strName = Mid(strName, InStr(1, strName, Chr(46)) + 1)
                strName = Replace(strName, Chr(13), "")
            End If
            Exit For
        End If
    Next oPara
    With oRng.Find
        Do While .Execute("Account Number : ")
            strAcc = oRng.Next.Words(1)
            Exit Do
        Loop
    End With
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute("Currency : ")
            oRng.End = oRng.Paragraphs(1).Range.End - 1
            oRng.MoveStartUntil "0123456789"
            strBalance = oRng.Text
            Exit Do
        Loop
    End With
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute("Scheme : ")
            strScheme = oRng.Next.Words(1)
            Exit Do
        Loop
    End With
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute("Rephased on : ")
            oRng.Collapse 0
            oRng.MoveEndWhile "-0123456789"
            strDate = Replace(oRng.Text, "-", ".")
            Exit Do
        Loop
    End With
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute("TOTAL OVERDUE : ")
            oRng.Collapse 0
            oRng.MoveEndWhile ",.0123456789"
            strTotal = oRng.Text
            Exit Do
        Loop
    End With

   
    MsgBox strName & vbCr & _
    strAcc & vbCr & _
    strBalance & vbCr & _
    strScheme & vbCr & _
    strDate & vbCr & _
    strTotal
lbl_Exit:
    Exit Sub
End Sub

Sub Macro1()
    ExtractData ActiveDocument
End Sub

---