Macro that copies text with certain formatting into separate columns in table

[michael_m]

Hi,
firstly, I'd like to say 'hello', I'm new here:)

Secondly, I want to have this English, Polish, French and the description text copied into separate columns (in order to make a termbase for translation purposes). The document has ca. 500 pages so doing it manually would take light years (the irony intended :))
It looks like this (picture related):
15896
...and I want it like this (might be in the same document, doesn't matter):
15897Fortunately, each language (plus the description) is formatted in a different way.

So I'm thinking about some VBA Macro that searches for bolded text, creates a table, adds a row and copies the text into a cell. Any ideas, which methods, function to use? I have very little experience with VBA so I need your help.
Thanks in advance :)

[gmayor]

It would have helped if you had used the same section from your original document in the required output as it is difficult to see how the two are related.
Can we assume that you are starting with a two column table and you require a five column table with the values from column 1 transcribed to columns 1 2 and 3 and the values from column 2 to columns 4 and 5?
That being the case it should be pretty straightforward. Can you post a sample of the document - (a page will do).

[michael_m]

Can we assume that you are starting with a two column table and you require a five column table with the values from column 1 transcribed to columns 1 2 and 3 and the values from column 2 to columns 4 and 5?

Yes, that's the case exactly.

Ok, here's the sample:
15925

[gmayor]

If the table is consistently formatted (which the sample isn't) the following will work. As the table isn't consistently formatted, it will need some remedial work

Option Explicit

Sub Macro1()
Dim oSource As Document
Dim oTarget As Document
Dim oTable1 As Table
Dim oTable2 As Table
Dim lngRow As Long
Dim oSRng As Range
Dim oTRng As Range
Dim oPara As Range
On Error GoTo err_Handler
Set oSource = ActiveDocument
Set oTable1 = oSource.Tables(1)
Set oTarget = Documents.Add
Set oTable2 = oTarget.Tables.Add(oTarget.Range, 1, 5)
For lngRow = 1 To oTable1.Rows.Count
Set oSRng = oTable1.Rows(lngRow).Cells(1).Range

Set oTRng = oTable2.Rows.Last.Cells(1).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(1).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oTRng = oTable2.Rows.Last.Cells(2).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(2).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oTRng = oTable2.Rows.Last.Cells(3).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(3).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oSRng = oTable1.Rows(lngRow).Cells(2).Range

Set oTRng = oTable2.Rows.Last.Cells(4).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(1).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oTRng = oTable2.Rows.Last.Cells(5).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs.Last.Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText
If lngRow < oTable1.Rows.Count Then oTable2.Rows.Add

Next lngRow
lbl_Exit:
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
End Sub

[michael_m]

Thanks, it works great (after some remedial work ofc). You're da real MVP :)

If it wouldn't be a problem, could you add some comments to the code? What was your way of thinking and idea of this 'app'. I just want to not only have this thing done but also to learn something.

[gmaxey]

As Graham is on the other side of the world I think he may have signed off for his night. I would have done this differently, but certainly not better.


Sub ConvertTableLayout()
Dim oTarget As Document
Dim oTbl As Table
Dim lngIndex As Long
Dim oRow As Row
Dim oCell As Cell
Dim oPar As Paragraph
On Error GoTo err_Handler
'Get the table of interest.
ActiveDocument.Tables(1).Range.Copy
'Create a new document to display new table layout
Set oTarget = Documents.Add
'Copy the table of interest to the new document
oTarget.Range.Paste
'Set a table oject variable.
Set oTbl = oTarget.Tables(1)
'Split the cells
For lngIndex = 1 To oTbl.Rows.Count
oTbl.Cell(lngIndex, 1).Split 1, 3
oTbl.Cell(lngIndex, 4).Split 1, 2
Next lngIndex
'Fix some of your formatting issues.
With oTbl
.TopPadding = InchesToPoints(0.01)
.BottomPadding = InchesToPoints(0.01)
.LeftPadding = InchesToPoints(0.02)
.RightPadding = InchesToPoints(0.02)
End With
For Each oRow In oTbl.Rows
oRow.HeightRule = wdRowHeightAuto
Next oRow
For Each oCell In oTbl.Range.Cells
For Each oPar In oCell.Range.Paragraphs
With oPar.Range.ParagraphFormat
.LeftIndent = 0
.RightIndent = 0
.Alignment = wdAlignParagraphLeft
End With
Next
Next
lbl_Exit:
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
End Sub



Now that my night is here, I just realized that like Graham you are on the other side of the world as well!

[gmayor]

The following is an annotated version of my original code with a couple of minor changes spotted during the annotation.
Greg's method is an alternative approach, with a different set of compromises, though his table formatting needs a little work to fit the last column completely on the page.


Option Explicit

Sub Macro1()
'Declare the variables used
Dim oSource As Document
Dim oTarget As Document
Dim oTable1 As Table
Dim oTable2 As Table
Dim lngRow As Long
Dim oSRng As Range
Dim oTRng As Range
Dim oPara As Range


On Error GoTo err_Handler
'Identify the document to be processed
Set oSource = ActiveDocument
'Identify the table to be processed
Set oTable1 = oSource.Tables(1)
'Add a new document for the modified table
Set oTarget = Documents.Add
'Create a new table to take the revised data
Set oTable2 = oTarget.Tables.Add(oTarget.Range, 1, 5)
'Process each row
For lngRow = 1 To oTable1.Rows.Count
'Set a range to the first cell
Set oSRng = oTable1.Rows(lngRow).Cells(1).Range
'Set a range to the first cell of the last row in thetarget table
Set oTRng = oTable2.Rows.Last.Cells(1).Range
'Omit the cell end character from the range
oTRng.End = oTRng.End - 1
'Set a range to the first paragraph of the source range
Set oPara = oSRng.Paragraphs(1).Range
'Omit the paragraph break character from the range
oPara.End = oPara.End - 1
'Put the paragraph range in the target cell
oTRng.FormattedText = oPara.FormattedText

'Repeat for other cells and paragraphs
Set oTRng = oTable2.Rows.Last.Cells(2).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(2).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oTRng = oTable2.Rows.Last.Cells(3).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(3).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oSRng = oTable1.Rows(lngRow).Cells(2).Range

Set oTRng = oTable2.Rows.Last.Cells(4).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs(1).Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText

Set oTRng = oTable2.Rows.Last.Cells(5).Range
oTRng.End = oTRng.End - 1
Set oPara = oSRng.Paragraphs.Last.Range
oPara.End = oPara.End - 1
oTRng.FormattedText = oPara.FormattedText
If lngRow < oTable1.Rows.Count Then oTable2.Rows.Add
DoEvents
Next lngRow
lbl_Exit:
'Clean up
Set oSource = Nothing
Set oTarget = Nothing
Set oTable1 = Nothing
Set oTable2 = Nothing
Set oSRng = Nothing
Set oTRng = Nothing
Set oPara = Nothing
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
End Sub