Cut and Paste Tables

[rasika99]

Friends,

I have a word document which consists of hundreds of tables with numbered descriptions (as mentioned in Example).

I have to fill these tables with required details and some tables to be kept blank if there are no details to fill. In such instances, I place the notation “No Observations**”.

At the end of the exercise, all the tables + descriptions which contains the notation “No Observations**” to be cut and paste in to a new word document and saved in “D:\empty files” folder.

Existing​ document should include only data-filled tables.

Can u guys help me to do this with a VBA code?

16065

[gmaxey]

Hard to tell what you are after. Could you provide 1) Example of what the document looks like when you are ready to process, 2) What the document looks like after the process and 3) What the new saved document should look like.

[gmayor]

What you ask is not straightforward, particularly with a document like your sample which is inconsistently formatted, does not use paragraph styles and has a raft of empty paragraphs. The essential problem is to determine where the start and end of the sections to be cut and pasted lie. The obvious way to do this is to locate the numbered paragraphs either side of the 'No Observations' text (which the example macro below will do), but then if you cut and paste the paragraphs, this will change the automatic numbering in both documents. If you convert the automatic numbering to fixed numbering, and thus maintain the numbers, you cannot use the auto numbering to locate the start and end paragraphs.

Option Explicit
Sub CutAndPasteTables()
Dim oSource As Document
Dim oTarget As Document
Dim oRng As Range
Dim oTRng As Range
Dim oTable As Range
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oRng = oSource.Range
With oRng.Find
Do While .Execute(FindText:="No Observations")
Set oTable = oRng
oTable.End = oRng.Paragraphs(1).Range.Next.Paragraphs(1).Range.End
Do While oTable.Paragraphs(1).Range.ListFormat.ListType = wdListNoNumbering
oTable.start = oTable.Paragraphs(1).Range.Previous.Paragraphs(1).Range.start
Loop
oTable.start = oTable.Paragraphs(1).Range.start
oTable.Cut
Set oTRng = oTarget.Range
oTRng.Collapse 0
oTRng.Paste
oRng.Collapse 0
Loop
End With
lbl_Exit:
Set oSource = Nothing
Set oTarget = Nothing
Set oRng = Nothing
Set oTRng = Nothing
Set oTable = Nothing
Exit Sub
End Sub

[rasika99]

thanks Greg and Graham. I think Graham's solution was almost the one I wanted (1608416085.

by the way, can we do this by identifying the empty tables within two numbering? Its all right to cut and paste all the numbering with empty tables. Is it possible to add a status bar as the document is bit larger. Auto numbering is also all right.

thanks
Rasika

[gmayor]

There seems to be an issue with your latest attachments ?

[Kilroy]

Is there an easy way to move all tables within a document to a new document? with no conditions? Just find them cut and paste to a new doc?

[Kilroy]

I have the following and tried adding do until and do while statement without success. This one only works for the first one. Any hints for a newbie on how to loop this?


Sub CutAndPasteTables()
If ActiveDocument.Tables.Count > 0 Then
ActiveDocument.Tables(1).Range.Cut
Documents.Add.Content.Paste
End If
End Sub

[gmayor]

Sub CutAndPasteTables()
Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As Range
Set oSource = ActiveDocument
If oSource.Tables.Count > 0 Then
Set oDoc = Documents.Add
Else
MsgBox "There are no tables in the current document"
GoTo lbl_Exit
End If
For Each oTable In oSource.Tables
oTable.Range.Cut 'Copy?
Set oRng = oDoc.Range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.Range.InsertParagraphAfter
Next oTable
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Thanks Graham works great. I added a couple of lines so that it saves it and then closes it. Is there a way to get it to save with the same title as the original document the tables are from with an "_tables" added to the name and have it save to the same folder as the original?


Sub CutAndPasteTables()
Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As range
Set oSource = ActiveDocument
If oSource.Tables.Count > 0 Then
Set oDoc = Documents.Add
Else
MsgBox "There are no tables in the current document"
GoTo lbl_Exit
End If
For Each oTable In oSource.Tables
oTable.range.Cut 'Copy?
Set oRng = oDoc.range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.range.InsertParagraphAfter
Next oTable
lbl_Exit:

ActiveDocument.SaveAs FileName:="C:\Original Backups\tables.docx"
ActiveDocument.Close
Exit Sub
End Sub

[gmayor]

You would have to store the full name and path of the original document in a string variable, then close it and save the new document with the name of the variable. It will save irrevocably and without warning.
Don't use activedocument, refer to the documents by the variable names and then you won't make mistakes.


Dim strName as String 'sat the top with the other variables

'The rest of the code

strName = oSource.FullName 'get the document path
oSource.Close 0 'Close it without saving
oDoc.SaveAs2 FileName:=strName 'Save the new document
lbl_Exit: 'Goes here!

[Kilroy]

Graham thanks but there is an issue. What's happening is that it's removing the tables closing the original and then saving just the tables with the original file name. I took out the line that closes the original and tried adding "_Tables to the strName line and the save as line but I can't get it to work it does add "_Tables" but past the file extension. (testDoc.docx_Tables)


Sub CutAndPasteTables()
Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As range
Dim strName As String 'sat the top with the other variables
Set oSource = ActiveDocument
If oSource.Tables.Count > 0 Then
Set oDoc = Documents.Add
Else
MsgBox "There are no tables in the current document"
GoTo lbl_Exit
End If
For Each oTable In oSource.Tables
oTable.range.Cut 'Copy?
Set oRng = oDoc.range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.range.InsertParagraphAfter
Next oTable
strName = oSource.FullName 'get the document path
oDoc.SaveAs2 FileName:=strName 'Save the new document
oDoc.Close
lbl_Exit:
Exit Sub
End Sub

[gmayor]

Sorry. I thought that was what you wanted - I missed the bit about the addition of the "_Tables" :(


strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & "_Tables.docx"

[Kilroy]

Thanks Graham works perfect now.