Macro to copy multiple tables in a single sheet from excel to word doc

Hi, I am Macro beginner and I am trying to write a macro in Excel 2013 that will copy data from a single sheet and paste it into a word 2013 doc. The data in the excel sheet consists of various tables with varying columns and rows. The sample data is as follows:
Attachment 10855

I would like the code to go through the excel sheet and identify the various tables and copy the tables into a word doc. The tables should be copied one after the other with some spacing between them and should have proper formatting such as auto fit column width.

I tried writing the code but all I have been able to do is to copy data from excel and paste it as a whole to the doc. My code is shown below.

Code:

---

Sub MacroStudent()
'Step 1:  Declare your variables
    Dim MyRange As Excel.Range
    Dim MyRange1 As Excel.Range
    Dim MyCell As Excel.Range
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim WdRange As Word.Range
    Dim wdTable As Word.Table
    Dim wdBreak As Word.Break
    Dim LastRow As Long
    Dim LastColumn As Long
   
 'Step 1.1: Capture the last used row and column number.
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
   
 
'Step 2:  Copy the defined range
    Sheets("Page1-1").Range("A9:j14").Copy
   
       
   
'Step 3:  Open the target Word document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add 'create a new document
    wd.Visible = True
   
'Step 4:  Set focus on the target
    Set WdRange = wdDoc.Range


'Step 4.1: Create a blank table in Word
  Set wdTable = wdDoc.Tables.Add(Range:=WdRange, NumRows:=62, NumColumns:=20)
   
'Step 5:  Delete the old table and paste new
    On Error Resume Next
    WdRange.Tables(1).Delete
    WdRange.Paste 'paste in the table
   
   
'Step 6:  Adjust column widths
       
    WdRange.Tables(1).AutoFitBehavior wdAutoFitWindow
    'WdRange.Tables(1).Columns.AutoFit
   
'Step 7:  Memory cleanup
    Set wd = Nothing
    Set wdDoc = Nothing
    Set WdRange = Nothing
   
End Sub

---

Can anyone help me with this? Thanks in advance.

Welcome to the forum!

I don't think you mean Excel tables but Excel Ranges as Tables to MSWord. Obviously, autofitting will not be good for large tables.

'Add Table to MSWord
' http://vbaexpress.com/forum/showthread.php?t=23975
' http://vbaexpress.com/forum/showthread.php?p=168731

Code:

---

' Tools > References > Microsoft Word 14.0 Object Library > OK
Sub MacroStudent()
    'Step 1:  Declare your variables
    Dim MyRange As Excel.Range
    Dim MyRange1 As Excel.Range
    Dim MyCell As Excel.Range
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim WdRange As Word.Range
    Dim wdTable As Word.Table
    Dim wdBreak As Word.Break
    Dim LastRow As Long
    Dim LastColumn As Long
   
    Dim i As Integer
    Dim a(1 To 2) As Range
    Set a(1) = Range("A6:J11")
    Set a(2) = Range("A12:R21")
         
   
    'Step 3:  Open the target Word document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add 'create a new document
    wd.Visible = True
   
    'Step 4:  Set focus on the target
    Set WdRange = wdDoc.Range
   
   
    'Step 4.1: Create a blank table in Word
    For i = 1 To UBound(a)
      a(i).Copy
      With wd.Selection
        .Paste 'paste in the table
        'Step 6:  Adjust column widths
        .Tables(1).AutoFitBehavior wdAutoFitContent
        .EndKey Unit:=wdStory
        .TypeParagraph
      End With
    Next i
   
    'Step 7:  Memory cleanup
    Application.CutCopyMode = False
    Range("A1").Select
    Set wd = Nothing
    Set wdDoc = Nothing
    Set WdRange = Nothing
End Sub

---

Thank you for your quick response and the code. Yes, you are right I meant ranges. The step 4.1 in the code is exactly what I needed. Thanks again.

Is there any way to make the ranges dynamic? Maybe the code can search for the word "Table" in the first column and then copy the range for that table and paste it.

As I am a newbie if you don't mind, could you explain

Code:

---

.EndKey Unit:=wdStory

---

The only way to do it dynamically would be to use an exact naming convention or structure in your worksheet. If the data is formatted as you posted, that can be done.

For the code, when working in MSOffice, the VBA macro recorder is your friend. When you paste, your cursor is at the top left. To get to the end, press Ctrl+End. That is what the command does for you.

Yes, the data is formatted as given the sample. Any idea on how it can be done?

This might seem complicated, but it is very logical providing your data is logical.

I don't have time to finish this for you right now. If you want to try, here is the concept.

1. Find the ranges with the word "Table " in Column 1.
2. Iterate each cell and offset by 1 row and find the number of columns in that row.
3. Create the Range to Copy based on the cell for each found range and the cell set by row of the next found cell range minus one row and the total number of columns.
a. Step 3 takes a bit of work but you have everything needed from steps 1 and 2. The only issue will be the last found range's last row.

For (2) replace activecell with a cell range from the found ranges in (1).
e.g.

Code:

---

cells(activecell.Row+1,columns.Count).end(xltoleft).column

---

For (1), you don't need the test sub. It is just to show how the routine is used:

Code:

---

' Chip Pearson, http://www.cpearson.com/excel/FindAll.aspx
'Kenneth, http://www.vbaexpress.com/forum/showthread.php?t=38802
Sub Test_FoundRanges()
  Dim findRange As Range, findString As String, foundRange As Range
  Dim r As Range, i As Long
 
  On Error GoTo EndNow:
  'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
  SpeedOn
 
  Set findRange = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
  findString = "Allocation"
  Set foundRange = FoundRanges(findRange, findString)
  If foundRange Is Nothing Then GoTo EndNow
 
  'If Not foundRange Is Nothing Then MsgBox foundRange.Address 'Note that range is in reverse order
  'If Not foundRange Is Nothing Then foundRange.EntireRow.Delete
  'For i = i to foundRange.Areas.Count
  '  foundRange.Areas(i).EntireRow.Delete
  'Next i
 
EndNow:
  SpeedOff
End Sub

Function FoundRanges(fRange As Range, fStr As String) As Range
    Dim objFind As Range
    Dim rFound As Range, FirstAddress As String
   
    With fRange
        Set objFind = .Find(what:=fStr, After:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
        LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=True)
        If Not objFind Is Nothing Then
            Set rFound = objFind
            FirstAddress = objFind.Address
            Do
                Set objFind = .FindNext(objFind)
                If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
            Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
        End If
    End With
    Set FoundRanges = rFound
End Function

---

For (3), this will be needed to build the table range of the last table.

Code:

---

Range("A" & rows.Count).End(xlUp).Row

---

Thanks a lot for your valuable input. I will try to work on the given concept. If I get stuck I know who to ask. :)

I enjoyed reading this post. I congratulate you for the terrific job you've made. Great stuff, just simply amazing!

How will I traverse through the ranges which have been stored through union in "foundranges"?

Finally got time to get back to this. Edit your tables to be sure that the find strings can be found. Specifically, use "Total (" rather than "Total(". The main thing is, be consistent.

Code:

---

' Tools > References > Microsoft Word 14.0 Object Library > OK
Sub MacroStudent2()
    'Step 1:  Declare your variables
    Dim MyRange As Excel.Range
    Dim MyRange1 As Excel.Range
    Dim MyCell As Excel.Range
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim WdRange As Word.Range
    Dim wdTable As Word.Table
    Dim wdBreak As Word.Break
    Dim LastRow As Long
    Dim LastColumn As Long
   
    Dim fTable As Range, fTotal As Range, r As Range, c As Range
    Dim nCols As Integer, i As Integer
   
    'Set fTable = FindAll(ActiveSheet.UsedRange, "Table ", xlValues, xlPart)
    'Set fTotal = FindAll(ActiveSheet.UsedRange, "Total (", xlValues, xlPart)
    Set fTable = FoundRanges(ActiveSheet.UsedRange, "Table ", xlPart)
    Set fTotal = FoundRanges(ActiveSheet.UsedRange, "Total (", xlPart)
    If fTable Is Nothing Or fTotal Is Nothing Then Exit Sub
   
    'Open the target Word document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add 'create a new document
    wd.Visible = True
   
    'Set focus on the target
    Set WdRange = wdDoc.Range

    'Create a blank table in Word
    For i = 1 To fTable.Cells.Count

      Set r = Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft)
      nCols = r.Areas.Count + Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft).Column
      Set r = Range(fTable.Areas(i), Cells(fTotal.Areas(i).Row, nCols))
      r.Copy
      With wd.Selection
          .Paste 'paste in the table
          'Adjust column widths
          .Tables(1).AutoFitBehavior wdAutoFitContent
          .EndKey Unit:=wdStory
          .TypeParagraph
      End With
    Next i
   
    'Memory cleanup
    Application.CutCopyMode = False
    Range("A1").Select
    Set wd = Nothing
    Set wdDoc = Nothing
    Set WdRange = Nothing
End Sub
 
 
 ' Chip Pearson, http://www.cpearson.com/excel/FindAll.aspx
 'Kenneth, http://www.vbaexpress.com/forum/showthread.php?t=38802
 
Function FoundRanges(fRange As Range, fStr As String, Optional aPart As Integer = xlWhole) As Range
    Dim objFind As Range
    Dim rFound As Range, FirstAddress As String
   
    With fRange
        Set objFind = .Find(what:=fStr, After:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
        LookIn:=xlValues, LookAt:=aPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=True)
        If Not objFind Is Nothing Then
            Set rFound = objFind
            FirstAddress = objFind.Address
            Do
                Set objFind = .FindNext(objFind)
                If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
            Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
        End If
    End With
    Set FoundRanges = rFound
End Function

---

What can I say? You are awesome..:clap2: Truly you are a GURU..:thumb My Hats off to you...

One little thing, The last column of Table 1-1-2 is not being copied over to the word. I am not able to figure why that is happening.


One more thing, can we implement this code without the use of finding "Total (". Because, some tables do not have the last row as Total. And makes this even more complicated.. :(

- separate the 'tables' by an empty row

Code:

---

Sub M_snb()
  With CreateObject("scripting.dictionary")
        For Each cl In Columns(1).SpecialCells(2)
            x0 = .Item(cl.CurrentRegion.Address)
        Next
        sn = .keys
    End With
       
    With CreateObject("Word.document")
      .Application.Visible = True
      For Each it In sn
          .Content.InsertAfter String(5, vbCr)
          Range(it).Copy
          .Paragraphs.last.Range.Paste
      Next
    End With
End Sub

---

NB. If you use real tables (VBA Listobjects), the code can be much simpler. MenuBar / Insert / Table

- Avoid 'Select' and 'Activate in VBA
- Avoid merged cells in Excel

Thank you for such a concise code SNB. Inserting spaces is a very smart idea. However, when the tables are being pasted the formatting is being lost and the tables do not fit in the page.

Comments about your code should not be taken as criticism but as ways to help you for this project or the next. I make those myself sometimes but they are not always taken as being helpful.

As snb noted, merged cells will make programming more challenging. That was the issue with the dropped column. I knew that but forgot to check before I finished posting example 2 in post #10.

For snb's comment about the blank row, consistency is the key to whatever coding project you attempt. I call it being logical. Code must be logical which means that data structure should be logical as well.

While snb's comment about Select and Activate are true, there are cases such as how I used Select, where it makes sense.

Thanks for the flowers ironfury.

Code:

---

Sub MacroStudent3()
    'Step 1:  Declare your variables
    Dim MyRange As Excel.Range
    Dim MyRange1 As Excel.Range
    Dim MyCell As Excel.Range
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim WdRange As Word.Range
    Dim wdTable As Word.Table
    Dim wdBreak As Word.Break
    Dim LastRow As Long
    Dim LastColumn As Long
   
    Dim fTable As Range, r As Range, c As Range
    Dim nCols As Integer, i As Integer, nLastRow As Long
   
    'Set fTable = FindAll(ActiveSheet.UsedRange, "Table ", xlValues, xlPart)
    Set fTable = FoundRanges(Range("A1", "R21"), "Table ", xlPart)
    If fTable Is Nothing Then Exit Sub
   
    'Open the target Word document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add 'create a new document
    wd.Visible = True
   
    'Set focus on the target
    Set WdRange = wdDoc.Range
   
    'Find last row of last table (last cell in column A with data).
    nLastRow = Cells(Rows.Count, "A").End(xlUp).Row
       
    'Create a blank table in Word
    For i = 1 To fTable.Cells.Count

      Set r = Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft)
      nCols = r.MergeArea.Cells.Count + Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft).Column - 1
      If i <> fTable.Cells.Count Then
        Set r = Range(fTable.Areas(i), Cells(fTable.Areas(i + 1).Row - 1, nCols))
        Else
          Set r = Range(fTable.Areas(i), Cells(nLastRow, nCols))
      End If
      r.Copy
      With wd.Selection
          .Paste 'paste in the table
          'Adjust column widths
          .Tables(1).AutoFitBehavior wdAutoFitContent
          .EndKey Unit:=wdStory
          .TypeParagraph
      End With
    Next i
   
    'Memory cleanup
    Application.CutCopyMode = False
    Range("A1").Select
    Set wd = Nothing
    Set wdDoc = Nothing
    Set WdRange = Nothing
End Sub

---

Well Said, Mr. Hobs. And Thank you once again for responding in a timely manner. The code given by you just nails it. :cloud9: It works perfectly on the sample report.

But when I try to modify it and run on the actual report, it's another story. :crying:

Attachment 10880

I know I should have provided you this earlier. It contained sensitive data that's why I didn't do it in the first place. My sincere apologies.

I added an empty row after each 'table'.

I ran my code.
See the result in the attachment.
No formatting (???)

I you remove all merged you can also use another method:

Code:

---

Sub M_snb()
    c00 = "G:\OF\0_Actual_report.xlsm"
    With CreateObject("scripting.dictionary")
        For Each cl In GetObject(c00).Sheets(1).Columns(1).SpecialCells(2)
            x0 = .Item(cl.CurrentRegion.Address)
        Next
        GetObject(c00).Close -1
        sn = .keys
    End With
   
    With CreateObject("Word.document")
        .Application.Visible = True
        For Each it In sn
          .Content.InsertAfter String(5, vbCr)
          .Fields.Add .Paragraphs.Last.Range, -1, "INCLUDETEXT " & Replace(c00, "\", "\\") & " " & it
        Next
        .Fields.Update
    End With
End Sub

---

This is probably about as close as I can get. Notice that I added a routine that checks the last column two rows below the row with the word "Table " to find the last column.

Code:

---

' Tools > References > Microsoft Word 14.0 Object Library > OK
Sub MacroStudent4()
    'Step 1:  Declare your variables
    Dim MyRange As Excel.Range
    Dim MyRange1 As Excel.Range
    Dim MyCell As Excel.Range
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim WdRange As Word.Range
    Dim wdTable As Word.Table
    Dim wdBreak As Word.Break
    Dim LastRow As Long
    Dim LastColumn As Long
   
    Dim fTable As Range, r As Range, c As Range
    Dim nCols As Integer, i As Integer, nLastRow As Long
   
    Set fTable = FindAll(ActiveSheet.UsedRange, "Table ", xlValues, xlPart)
    'Set fTable = FoundRanges(ActiveSheet.UsedRange, "Table ", xlPart)
    If fTable Is Nothing Then Exit Sub
   
    'Open the target Word document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add 'create a new document
    wd.Visible = True
   
    'Set focus on the target
    Set WdRange = wdDoc.Range
   
    'Find last row of last table (last cell in column A with data).
    nLastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 ' -1 since a date row is added
   
    'Create a blank table in Word
    For i = 1 To fTable.Cells.Count
       
        'Set r = Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft)
        'nCols = r.MergeArea.Cells.Count + Cells(fTable.Areas(i).Row + 1, Columns.Count).End(xlToLeft).Column - 1
        nCols = LastColInRow(Cells(fTable.Areas(i).Row + 2, Columns.Count)) 'Check last column by 2 rows below Table's 1st row.
        If i <> fTable.Cells.Count Then
            Set r = Range(fTable.Areas(i), Cells(fTable.Areas(i + 1).Row - 1, nCols))
        Else
            Set r = Range(fTable.Areas(i), Cells(nLastRow, nCols))
        End If
        r.Copy
        With wd.Selection
            .Paste 'paste in the table
            'Adjust column widths
            .Tables(1).AutoFitBehavior wdAutoFitContent
            .EndKey Unit:=wdStory
            .TypeParagraph
        End With
    Next i
   
    'Memory cleanup
    Application.CutCopyMode = False
    Range("A1").Select
    Set wd = Nothing
    Set wdDoc = Nothing
    Set WdRange = Nothing
End Sub

 ' Chip Pearson, http://www.cpearson.com/excel/FindAll.aspx
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
              Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean

CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If

' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.

For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        After:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)

If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False ' Loop forever. We'll "Exit Do" when necessary.
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(After:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If

    Loop
End If
   
Set FindAll = ResultRange

End Function

Function LastColInRow(aCell As Range) As Integer
  Dim LastCell As Range
  Set LastCell = Worksheets(aCell.Parent.Name).Cells(aCell.Row, Worksheets(aCell.Parent.Name).Columns.Count)
  Set aCell = LastCell
  Do Until aCell.Column = 1 Or (LastCell.DisplayFormat.Interior.Color <> aCell.DisplayFormat.Interior.Color)
    Set aCell = aCell.Offset(0, -1)
  Loop
  'LastColInRow = aCell.Column + aCell.MergeArea.Cells.Count - 1
  LastColInRow = aCell.Column
End Function

---

Sorry for reply so late. Mr. Hobs you amaze me yet again. :clap2: You have written an outstanding piece of code. What would have taken me weeks you have done it in a day. The code which you written does everything perfectly. Amazing. :super:Thank you so much. I never thought this forum would have been so much help to me. I hope that one day I can help others similarly.

I am marking this as solved and again Thank you very very much.

Quote:

---

Originally Posted by Eponine22

I enjoyed reading this post. I congratulate you for the terrific job you've made. Great stuff, just simply amazing!

---

Post very nicely written and it contains useful facts. I am happy to find your distinguished way of writing the post. Thanks a lot.