Macro to select only tables in Word

[AnnaL]

I found a macro (below) that will select all tables in a Word document. However, when I go to copy and paste the tables in a separate Word document the table layout gets lost and only the physical text transfers. Does anyone know how to tweak this macro or provide another one. Any help would be appreciated.


Sub selecttables()
Dim mytable As Table
Application.ScreenUpdating = False

For Each mytable In ActiveDocument.Tables
mytable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
Application.ScreenUpdating = True
End Sub

[Kilroy]

This will do the trick for you. This code was written by someone else, probably Greg or Graham.


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.Copy
Set oRng = oDoc.Range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.Range.InsertParagraphAfter
Next oTable
strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & " Tables.docx"
oDoc.SaveAs2 FileName:=strName 'Save the new document"
'oDoc.Close
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

If the goal is to copy a documents tables to the clipboard, you can use this:


Sub CopyDocTablesToClipboard()
Dim oTbl As Table
Dim oDoc As Document
Dim oTempDoc As Document
Dim oRng As Range
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set oTempDoc = Documents.Add(ThisDocument.AttachedTemplate.FullName, , , False)
For Each oTbl In oDoc.Tables
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oTbl.Range.Copy
oRng.Paste
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter vbCr
Next oTbl
oTempDoc.Range.Copy
oTempDoc.Activate
oTempDoc.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[AnnaL]

You all are great, thanks!

I didn't think about this, but the tables I use have typemarks (i.e., <tt>, <tfn>, <tcl>) that come before and after the table (which I have attached). Is there a way for that to be included in what the macro captures?

Below is a completely different macro that deals with typemarks if that gives you a sense of what I mean.

Dim curTypemark As String ' Variable for a typemark
curTypemark = "" ' Initial instantiation is the empty string

' This sub's code largely copies that of CheckTypemarks, so more verbose
' comments are in that sub
Dim oPrg As Paragraph ' placeholder for a paragraph

' Loop through each paragraph
For Each oPrg In ActiveDocument.Paragraphs
Dim paraRng As Range
Set paraRng = oPrg.Range

If (oPrg.Style = "tx" Or oPrg.Style = "sb1tx") Then
paraRng.MoveEnd Unit:=wdCharacter, Count:=-1
paraRng.InsertAfter (vbCr)
End If

If (Not (curTypemark = oPrg.Style)) Then
curTypemark = oPrg.Style

[gmaxey]

You get the first opening and closing set of tags like this but without more information it is impossible for me to take it any further.


Sub CopyDocTablesToClipboard()
Dim oTbl As Table
Dim oDoc As Document
Dim oTempDoc As Document
Dim oRng As Range, oCopyRange As Range
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set oTempDoc = Documents.Add(ThisDocument.AttachedTemplate.FullName, , , False)
For Each oTbl In oDoc.Tables
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
Set oCopyRange = oTbl.Range
With oCopyRange
.MoveStartUntil "<", wdBackward
.MoveStart 1, -1
.MoveEndUntil ">", wdForward
.MoveEnd 1, 1
.Copy
End With
oRng.Paste
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter vbCr
Next oTbl
oTempDoc.Range.Copy
oTempDoc.Activate
oTempDoc.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[AnnaL]

Thanks! That somewhat worked. It appeared to only capture the first typemark above and below the table. So, if, for instance, I had <tfn> and <tcl> below the table the <tcl> did not get copied. The issue is that the typemarks that could appear above or below the table could change depending on the project. Is there a way to include code that basically says if these typemarks appear above or below the table, please include in the copy and paste (and keep the same position either above or below the table as it does in the original document)? If that is possible, could you leave notes that basically say insert here the list of typemarks that you want to be included in whatever code you create. I would give you a list but it can be quite extensive given the project. I will say that all typemarks that could appear will begin and end with "< >" (e.g., <sb1tt>, <sb2tfn> <ttxni>, etc.). That said, the original document has typemarks outside of the table area that I wouldn't want to include, which is why I would need the code to specifically ignore some typemarks. Please let me know if you have any questions.

Also, do you mind building off of this code below? It's a couple of macros that I've put together (which makes all copy black, copies and pastes tables into new doc., removes background color and adds borders). I think it'll be easier than me trying to figure out where to add your code into the macro you created based on copy and paste into clipboard. Thank you so much in advance.



Sub CutandPaste()'
'
'CutandPaste Macro
'
'
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

'Change the values below to apply other borders
oBorderStyle = wdLineStyleSingle
oBorderWidth = wdLineWidth050pt
oBorderColor = wdColorBlack


'Define array with the borders to be changed
'Diagonal borders not included here
oArray = Array(wdBorderTop, _
wdBorderLeft, _
wdBorderBottom, _
wdBorderRight, _
wdBorderHorizontal, _
wdBorderVertical)


Selection.WholeStory

response = MsgBox("Make all text black?", vbYesNo)
If response = 6 Then
Selection.Font.Color = wdColorBlack
End If

For Each oTable In ActiveDocument.Tables
With oTable.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
Next


For Each oTable In ActiveDocument.Tables
n = n + 1
With oTable
For i = LBound(oArray) To UBound(oArray)
With .Borders(oArray(i))
.LineStyle = oBorderStyle
.LineWidth = wdLineWidth050pt
.Color = wdColorBlack
End With
Next i
End With
Next oTable

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.Copy
Set oRng = oDoc.Range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.Range.InsertParagraphAfter
Next oTable
strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & " Tables.docx"
oDoc.SaveAs2 FileName:=strName 'Save the new document"
'oDoc.Close
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

This is written by Greg and slightly modified by me to suit your needs.


Sub CutandPaste()

Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As Range
Dim oTempDoc As Document
Dim oCopyRange As Range
Dim strName As String
Set oSource = ActiveDocument

Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set oTempDoc = Documents.Add
For Each oTbl In oDoc.Tables
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
Set oCopyRange = oTbl.Range
With oCopyRange
.MoveStartUntil "<", wdBackward
.MoveStart 2, -1
.MoveEndUntil ">", wdForward
.MoveEnd 1, 1
.Copy
End With
oRng.Paste
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter vbCr
Next oTbl
oTempDoc.Range.Copy
oTempDoc.Activate

lbl_Exit:

Selection.WholeStory
'Change the values below to apply other borders
oBorderStyle = wdLineStyleSingle
oBorderWidth = wdLineWidth050pt
oBorderColor = wdColorBlack
'Define array with the borders to be changed
'Diagonal borders not included here
oArray = Array(wdBorderTop, _
wdBorderLeft, _
wdBorderBottom, _
wdBorderRight, _
wdBorderHorizontal, _
wdBorderVertical)

response = MsgBox("Make all text black?", vbYesNo)
If response = 6 Then
Selection.Font.Color = wdColorBlack
End If

For Each oTable In ActiveDocument.Tables
With oTable.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
Next


For Each oTable In ActiveDocument.Tables
n = n + 1
With oTable
For i = LBound(oArray) To UBound(oArray)
With .Borders(oArray(i))
.LineStyle = oBorderStyle
.LineWidth = wdLineWidth050pt
.Color = wdColorBlack
End With
Next I
End With
Next oTable
strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & "_Tables.docx"
oTempDoc.SaveAs2 FileName:=strName

End Sub

[AnnaL]

Thanks! I'm still running into the issue of the macro only carrying over the typemark directly before and after the table but not the rest. I have attached a Word file that shows you what I see before and after I apply the macro (I combined into one doc. rather than leaving the new table in a separate doc.). I then highlighted the typemarks that aren't showing up. The problem is that the number and wordings of typemarks that show up before or after the table could change. In the example I provided, there are two before and after the table, but it could just as easily be only one typemark before the table and three after the table. This is why I'm wondering if the code needs to specify what typemarks to copy and paste into the new document. The macro also cannot be so broad as to say all typemarks because the document the tables are being pulled from have typemarks that I don't want to include (also shown in the document, highlighted in red).

[Kilroy]

I don't see how a macro can tell the difference in the type marks as you have said they change based on the project.

[AnnaL]

Two questions.

1. They do change depending on the project, but 10 or so are used regularly. So, if I can create a macro that knows to cut and paste 10 or so specific typemarks with the table, that would be just as helpful (e.g., <tt>, <tfn>, <tcl>, etc.).

2. If not, can the macro be modified to include so many typemarks above and below the table, and I could just delete the miscellaneous ones? That would be better than the macro missing some typemarks.

[AnnaL]

I also meant to ask. I found a macro that will delete tables from the source document. Is there a way to incorporate that into the macro or that must be done separately because an entirely new document is created?

[Kilroy]

This still doesn't address the typemark issue but it does delete the copied tables.


Sub CutandPaste()

Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As Range
Dim oTempDoc As Document
Dim oCopyRange As Range
Dim strName As String
Set oSource = ActiveDocument

Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set oTempDoc = Documents.Add
For Each oTbl In oDoc.Tables
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
Set oCutRange = oTbl.Range
With oCutRange
.MoveStartUntil "<", wdBackward
.MoveStart 2, -1
.MoveEndUntil ">", wdForward
.MoveEnd 1, 1
.Cut
End With
oRng.Paste
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter vbCr
Next oTbl
oTempDoc.Range.Copy
oTempDoc.Activate

lbl_Exit:

Selection.WholeStory
'Change the values below to apply other borders
oBorderStyle = wdLineStyleSingle
oBorderWidth = wdLineWidth050pt
oBorderColor = wdColorBlack
'Define array with the borders to be changed
'Diagonal borders not included here
oArray = Array(wdBorderTop, _
wdBorderLeft, _
wdBorderBottom, _
wdBorderRight, _
wdBorderHorizontal, _
wdBorderVertical)

response = MsgBox("Make all text black?", vbYesNo)
If response = 6 Then
Selection.Font.Color = wdColorBlack
End If

For Each oTable In ActiveDocument.Tables
With oTable.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
Next


For Each oTable In ActiveDocument.Tables
n = n + 1
With oTable
For I = LBound(oArray) To UBound(oArray)
With .Borders(oArray(I))
.LineStyle = oBorderStyle
.LineWidth = wdLineWidth050pt
.Color = wdColorBlack
End With
Next I
End With
Next oTable
strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & "_Tables.docx"
oTempDoc.SaveAs2 FileName:=strName

End Sub

[AnnaL]

Maybe I am making this too complicated. Instead of thinking of the typemarks like typemarks, can we think of them like text. I'm not sure how but essentially putting in a text find "<typemark>" and then expand the range to include whatever comes after that typemark, i.e., "<typemark> Text here." Does that make sense?

[Kilroy]

beyond my skill

[AnnaL]

That's OK, thank you. I'll throw it back to gmaxey, do you have any ideas?

[gmaxey]

That's OK, thank you. I'll throw it back to gmaxey, do you have any ideas?

Yes, this is not a free code writing service. If you don't want to learn how to write code then hire someone to write if for you.

I told you in my last post that the code I provided would get the first leading and trailing flag (and not any that might prefix or suffix those). You can try this:


Sub CopyDocTablesToClipboard()
Dim oTbl As Table
Dim oDoc As Document
Dim oTempDoc As Document
Dim oRng As Range, oCopyRange As Range, oFlagRange As Range
Dim arrIncludes() As String
Dim lngIndex As Long
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
arrIncludes = Split("tcl,abc,def,ghi", ",")
Set oTempDoc = Documents.Add(ThisDocument.AttachedTemplate.FullName, , , False)
For Each oTbl In oDoc.Tables
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
Set oCopyRange = oTbl.Range
With oCopyRange
'Get first leading and trailing flags
If .Characters.First.Previous.Previous = ">" Then
.MoveStartUntil "<", wdBackward
.MoveStart 1, -1
End If
'Get first leading and trailing flags
If .Characters.Last.Next = "<" Then
.MoveEndUntil ">", wdForward
.MoveEnd 1, 1
Set oFlagRange = .Paragraphs.Last.Next.Range
If oFlagRange.Characters.First = "<" And oFlagRange.Characters.Last.Previous = ">" Then
For lngIndex = 0 To UBound(arrIncludes)
If InStr(oFlagRange.Text, "<" & arrIncludes(lngIndex) & ">") = 1 Then
.End = oFlagRange.End
Exit For
End If
Next
End If
End If
.Select
.Copy
End With
oRng.Paste
Set oRng = oTempDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter vbCr
Next oTbl
oTempDoc.Range.Copy
oTempDoc.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[AnnaL]

I apologize I misunderstood your response when you provided the earlier code.

Thanks.