Extracting data from one document and creating a new document in 2 columns.

[Teacha]

I would appreciate help from someone who could extend the work I have alread done.
Situation:
I have a word doc that consists of tables. I would like to use every 3rd table (starting with the second) to build a new document that shows the retrieved data in two columns.

Current code has two issues.
1: current data just replaces in the new document so i end up with just the last table copied in my new file.

2: I would like to paste the new tables retrieved from the old file into a new file that has two columns.

My current code looks like this.


Dim docMultiple As Document
Dim docSingle As Document
Dim rngtable As Range
Dim iCurrentTable As Integer
Dim i As Integer
Dim iTableCount As Integer
Dim strItCode As String
'Dim strCellText As String
'Dim fldnme As String
'Dim fnamLngth As Integer
Dim intMsgBoxResult As Integer
Dim strMsg As String
Dim itmCnt As String
'Dim strTestfile As String

Application.ScreenUpdating = False 'Makes the code run faster and reduces screen flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document _
(the one currently containing the items)

'Set rngtable = docMultiple.Range 'instantiate the range object
iCurrentTable = 2
'get the document's table/item count
iTableCount = docMultiple.Tables.Count
itmCnt = (ActiveDocument.Tables.Count) / 3

strMsg = "Number of items in this document: " + itmCnt + vbCr + " Continue?"

intMsgBoxResult = MsgBox(strMsg, vbYesNo + vbQuestion, "Mock up Notes")

If intMsgBoxResult = vbYes Then
Set docMultiple = ActiveDocument 'set docmultiple to be document to extract items from
Set docSingle = Documents.Add 'create a new document
Do Until iCurrentTable > iTableCount

'Select the table
docMultiple.Tables(iCurrentTable).Select
If Selection.Information(wdWithInTable) = True Then

'Selection.SetRange Start:=Selection.Tables(iCurrentTable)
Selection.Copy
Selection.EndKey Unit:=wdStory

'paste the clipboard contents to the new document

'Selection.InsertAfter vbCr
docSingle.Range.Paste EndOf(wdParagraph)

docSingle.Select
Selection.MoveDown Unit:=wdLine, Count:=1

'write item number in top left corner

'copy table to new file

'copy in item code

'advance table number selection for next time

'rngtable.End = Selection.Start

'adds a few spaces
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph

'Selection.WholeStory
'Selection.Font.Size = 10

'rngtable.Collapse wdCollapseEnd 'go to the next table
'End If
iCurrentTable = iCurrentTable + 3
End If
Loop 'go to the top of the do loop
Application.ScreenUpdating = True 'restore the screen updating


System.Cursor = wdCursorNormal
'Destroy the objects.
Set docMultiple = Nothing
Set docSingle = Nothing
Set rngtable = Nothing
End If

[MOS MASTER]

Hi,

I'm not entirly sure what you want to achieve.
Is it possible for you to include a sample document (to work with)
And a result document with the intended result after processing the sample document?

I'm sure that would help clarify things.

[Teacha]

9287

[Teacha]

9288

Thanks for any help you can provide.

[MOS MASTER]

Hi Teacha, :hi:

Those documents where very clear thank you this makes my live easy.

What you need is something like this: (you can add in the msgbox stuff you need at will)

Option Explicit

Dim oNewDoc As Word.Document

Sub CopyTablesToNewDocument()
Dim iTables As Integer
With ActiveDocument
If .Tables.Count < 2 Then Exit Sub 'leave if there are not tables to process
AddNewDocument 'add new document with columns

For iTables = 2 To .Tables.Count Step 3 'start at 2 and skip 3 for each loop
.Tables(iTables).Range.Copy
PasteInDocument 'paste the new table
Next
End With

Set oNewDoc = Nothing
End Sub

Sub AddNewDocument()
Set oNewDoc = Application.Documents.Add
With oNewDoc.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
.Width = CentimetersToPoints(6.7)
.Spacing = CentimetersToPoints(1.25)
End With
End Sub

Sub PasteInDocument()
Dim oRange As Range
Set oRange = oNewDoc.Range

With oRange
.Collapse wdCollapseEnd
.Paste
.Collapse wdCollapseEnd
.InsertAfter vbCr
End With
End Sub


HTH