Macro to select only tables in Word

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

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

Code:

---

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

---

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

Code:

---

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

---

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

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.

Code:

---

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

---

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.

Code:

---

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

---

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

Code:

---

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

---

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

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.

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.

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?

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

Code:

---

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

---

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?

beyond my skill

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

Quote:

---

Originally Posted by AnnaL

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:

Code:

---

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

---

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

Thanks.