VBA Word - Copy Strings into a Table

[saphire99]

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



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

[gmayor]

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

[saphire99]

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

[nitesh12]

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?

[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.

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

[nitesh12]

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.

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?

[gmayor]

The following should work. Write the strings to your worksheet
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