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

[ironfury]

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



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.

[Kenneth Hobs]

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


' 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

[ironfury]

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
.EndKey Unit:=wdStory

[Kenneth Hobs]

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.

[ironfury]

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

[Kenneth Hobs]

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.

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:

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

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

[ironfury]

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

[Eponine22]

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

[ironfury]

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

[Kenneth Hobs]

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.

' 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

[ironfury]

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

[ironfury]

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.. :(

[snb]

- separate the 'tables' by an empty row


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

[ironfury]

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.

[Kenneth Hobs]

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.


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

[ironfury]

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:

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.

[snb]

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:


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

[Kenneth Hobs]

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.


' 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

[ironfury]

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.

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