The macro is written in Excel. I have copied the table to word first page from excel and then I would like to insert table into page 2 in word.But from below the set "MyRange" returning empty and table with 1 row is not creating.
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(str_path_folder & "\" & AdID & ".dotm")
objWord.Visible = True
objDoc.Activate
AppActivate AdID & ".dotm"
Sheets("Meta").Select
Range("B1:E" & LastRow).Select
Selection.Copy
objWord.Selection.PasteExcelTable False, False, False
objDoc.Tables(1).AutoFitBehavior wdAutoFitContent
objWord.Selection.InsertBreak.Type = wdPageBreak
Set MyRange = ActiveDocument.Content
MyRange.collapse Direction:=wdCollapseEnd
ActiveDocument.Tables.Add Range:=MyRange, NumRows:=1, _
NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
Also if i use below it is replacing the already copied table in page 1:
objDoc.Tables.Add Range:=objDoc.Range, NumRows:=3, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
Another way to get the end of the document is objDoc.Range(objDoc.Range.End - 1)
objDoc.Range.PasteExcelTable 0, 0, 0
objDoc.Range(objDoc.Range.End - 1).InsertBreak
objDoc.Tables.Add objDoc.Range(objDoc.Range.End - 1), 2, 2
If you record the macro in Word, you get something like this
Selection.PasteExcelTable False, False, True
Selection.InsertBreak Type:=wdPageBreak
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1, _
DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
Related
Currently I am using a for loop to lay down 4 rounds of data, I was hoping to have it replace all that are corresponding to the current word template, but doing this all in excel VBA
Unfortunately the code that I am not using is no working and the wdReplaceAll = Empty.
I've tried resetting parameters and even having .Execute Replace:=wdReplaceAll changed to .Execute Replace:=1. But Nothing in my word document is being replaced
Dim WordApp As Object
Dim DocFileName As String
Set WordApp = CreateObject("Word.Application")
DocFileName = ActiveWorkbook.Path & "\Word\TCAP Update.docx"
WordApp.Documents.Open DocFileName
For i = 1 To TCAPCount
Summary(i) = ActiveCell.Offset(0, -1).Value
Key(i) = ActiveCell.Offset(0, -2).Value
Updated(i) = Format(ActiveCell.Offset(0, 1).Value, "MM/DD/YYYY")
Cells.Find(what:="NEAR DATE", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True).Activate
ColorInd = ActiveCell.DisplayFormat.Interior.Color
ActiveCell.Offset(0, 1).Select
Do Until ActiveCell.Value <> "NEAR DATE" And ActiveCell.DisplayFormat.Interior.Color = ColorInd
ActiveCell.Offset(0, 1).Select
Loop
ActualDate(i) = Format(ActiveCell.Value, "MM/DD/YYYY")
ActualDateNam(i) = Range(Split(ActiveCell(1).Address(1, 0), "$")(0) & "1").Value
Range(SEMCol & ActiveCell.Row).Select
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.EntireRow.Hidden = True Then
'keep looking
Else
Exit Do
End If
Loop
Next i
If TCAPCount > 1 Then
MsgBox "Please take this time to create " & TCAPCount & " extra TCAP Templates for " & SEM
WordApp.Visible = True
MsgBox "When you are ready to proceed please select OK"
End If
For i = 1 To TCAPCount
With WordApp.Selection.Find
.Text = "Key " & (i)
.Replacement.Text = Key(i)
.Execute Replace:=wdReplaceAll
.Text = "Summary " & (i)
.Replacement.Text = Summary(i)
.Execute Replace:=wdReplaceAll
.Text = "ActualDate " & (i)
.Replacement.Text = ActualDate(i)
.Execute Replace:=wdReplaceAll
.Text = "ActualDateNam " & (i)
.Replacement.Text = ActualDateNam(i)
.Execute Replace:=wdReplaceAll
.Text = "Updated " & (i)
.Replacement.Text = Updated(i)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next i
I am hoping to replace
Key 1 | Summary 1
ActualDateNam 1– ActualDate 1
Last Update: Updated 1
Key 2 | Summary 2
ActualDateNam 2– ActualDate 2
Last Update: Updated 2
Key 3 | Summary 3
ActualDateNam 3– ActualDate 3
Last Update: Updated 3
Key 4 | Summary 4
ActualDateNam 4– ActualDate 4
Last Update: Updated 4
with it's corresponding data ie i=1 and Key (i) = "Apples", then Key 1 will be replaced as "Apples".
If you use Option Explicit, vba compiler would complain about not knowingwdReplaceAllas you use late-bound word object, what prevents you using its enums.
You tried to fix that, but who told you thatwdReplaceAll = 1?
If you read the docs you see wdReplaceAll = 2
I created this code with macro recorder to get Pivot table automatically.
But when I run this code again an error message appears:
Run-time error 1004: Invalid reference
at this line Workbooks("works.xlsm").Connections.Add2.
Why is there invalid reference if this code was recorded? During the recording, I gave the name "database" for the table (R1C4:R18532C9). I use Windows 10 and Office 2016.
Range("D1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="database", RefersToR1C1:= _
"=Data!R1C4:R18532C9"
ActiveWorkbook.Names("database").Comment = ""
Range("D1").Select
Workbooks("works.xlsm").Connections.Add2 _
"WorksheetConnection_works.xlsm!database", "", _
"WORKSHEET;C:\Users\gabor\Documents\CAFM\VBS\works.xlsm", _
"works.xlsm!database", 7, True, False
ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:= _
ActiveWorkbook.Connections("WorksheetConnection_works.xlsm!database"), _
Version:=6).CreatePivotTable TableDestination:="Pivot!R1C1", TableName:= _
"Statement1", DefaultVersion:=6
Sheets("Pivot").Select
Cells(1, 1).Select
With ActiveSheet.PivotTables("Statement1").CubeFields("[database].[Person]")
.Orientation = xlRowField
.Position = 1
End With
The database table and the pivot results with xlCount and xlDistinctCount
Try edited code below, explanations are inside the code as comments.
xlDistinctCount is untested as I have Office 2010 (it's available from Officde 2013), but should work.
Code
Option Explicit
Sub AutoDynamicPivot()
Dim PT As PivotTable
Dim PTCache As PivotCache
Dim WB As Workbook
Dim Sht As Worksheet
Dim SrcData As Variant
Dim lRow As Long, lCol As Long
Set WB = ThisWorkbook
Set Sht = WB.Worksheets("Data") '<-- set the "Data" worksheet
lRow = Sht.Range("A1").End(xlDown).Row '<-- modifed from "D1" to "A1" (according to PO screen-shot)
lCol = Sht.Range("A1").End(xlToRight).Column '<-- modifed from "D1" to "A1" (according to PO screen-shot)
' set the Named Range "database" to the data in worksheet "Data"
WB.Names.Add Name:="database", RefersToR1C1:="=" & Sht.Name & "!R1C1:R" & lRow & "C" & lCol '<-- modifed to "R1C1" (according to PO screen-shot)
WB.Names("database").Comment = ""
' Determine the data range you want for your Pivot Cache
Set SrcData = Range("database")
' set the Pivot Cache
Set PTCache = ActiveWorkbook.PivotCaches.Add(xlDatabase, SrcData)
' add this line in case the Pivot table doesn't exit >> first time running this Macro
On Error Resume Next
Set PT = Worksheets("Pivot").PivotTables("Statement1") ' check if "Statement1" Pivot Table already created (in past runs of this Macro)
On Error GoTo 0
If PT Is Nothing Then
' create a new Pivot Table in "Pivot" sheet, start from Cell A1
Set PT = Worksheets("Pivot").PivotTables.Add(PivotCache:=PTCache, TableDestination:=Worksheets("Pivot").Range("A1"), TableName:="Statement1")
'Create the headings and row and column orientation and all of your other settings here
With PT
' set "Person" as rows field
With .PivotFields("Person")
.Orientation = xlRowField
.Position = 1
End With
' set "Month" as Filter
With .PivotFields("Month")
.Orientation = xlPageField
.Position = 1
End With
' set "Count of Cases"
.AddDataField .PivotFields("Case"), "Count of Case", xlCount
' set "Distinct Count of Cases"
.AddDataField .PivotFields("Case"), "Distinct Count of Case", xlDistinctCount
End With
Else
' just refresh the Pivot cache with the updated Range (data in "Data" worksheet)
PT.ChangePivotCache PTCache
PT.RefreshTable
End If
End Sub
Screen-shot of the Pivot-Table created with this code:
I changed the commandtext parameter in Connections.Add2 from "works.xlsm!database" to "Data!database". It solved the problem. I edited the ActiveWorkbook.Names.Add as well.
LastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
LastCol = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
ActiveWorkbook.Names.Add _
Name:="database", _
RefersTo:="=Data!R1C4:R" & LastRow & "C" & LastCol & ""
ActiveWorkbook.Connections.Add2 _
"WorksheetConnection_works.xlsm!database", "", _
"WORKSHEET;C:\Users\gabor\Documents\CAFM\VBS\works.xlsm", _
"Data!database", 7, True, False
ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:= _
ActiveWorkbook.Connections("WorksheetConnection_works.xlsm!database"), _
Version:=6).CreatePivotTable TableDestination:="Pivot!R1C1", TableName:= _
"Statement1", DefaultVersion:=6
Sheets("Pivot").Select
Cells(1, 1).Select
With ActiveSheet.PivotTables("Statement1").CubeFields("[database].[Person]")
.Orientation = xlRowField
.Position = 1
End With
I could get the xlDistinctCount with this code:
ActiveSheet.PivotTables("Statement1").CubeFields.GetMeasure "[database].[TT]" _
, xlCount
ActiveSheet.PivotTables("Statement1").AddDataField ActiveSheet.PivotTables( _
"Statement1").CubeFields("[Measures].[quantity of items - TT]")
With ActiveSheet.PivotTables("Statement1").PivotFields( _
"[Measures].[quantity of items - TT]")
.Caption = "number of distinct items – TT"
.Function = xlDistinctCount
End With
I had to use the xlCount first and with this result could I get the xlDistinctCount.
I have block of text in (A795:O830). It is separated from other pages by Page Break and is always the last page of printed (xls, pdf) document. Sometimes there are a lot of free space on first pages and (A795:O830) could have fitted there. Now it is done by Page Break and is not changeble. In my situation 66 rows can fit on one page.
Is there any macro that can automatically check if there is enough empty space on previous page to fit (A795:O830) and insert it there?
Here is my current macro:
Sub Remove_color()
Dim myRange As Range
Dim cell As Range
Set myRange = Range("A24:O785")
For Each cell In myRange
myRange.Interior.ColorIndex = 0
Next
End Sub
Sub Hide_empty_cells()
Set rr = Range("A24:N832")
For Each cell In rr
cell.Select
If cell.HasFormula = True And cell.Value = "" And cell.EntireRow.Hidden = False Then Rows(cell.Row).EntireRow.Hidden = True
Next cell
End Sub
Sub Save_excel()
Dim iFileName$, iRow&, iCol&, iCell As Range, iArr
iFileName = ThisWorkbook.Path & "\New_folder_" & [D5] & "_" & ".xls"
iArr = Array(1, 3, 4): iCol = UBound(iArr) + 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
ThisWorkbook.Sheets(2).Copy
With ActiveWorkbook.ActiveSheet
.Buttons.Delete '.Shapes("Button 1").Delete
.UsedRange.Value = .UsedRange.Value
.SaveAs iFileName, xlExcel8: .Parent.Close
End With
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Save_pdf()
ActiveWorkbook.Sheets(2).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\New_folder_\" & [D5] & "_" & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=No, _
OpenAfterPublish:=False
End Sub
Sub doitallplease()
Call Remove_color
Call Hide_empty_cells
Call Save_excel
Call Save_pdf
End Sub
I am having a problem with the result of my code: Main idea is that i have a word template where i copy paste different tables from an excel file. The tables are in 12 different sheets, named Table 1, Table 2, etc. When there is some data in these sheets, the code works perfectly. This is the entire code:
Sub CreateBasicWordReport()
'Create word doc automatically
Dim wApp As Word.Application
Dim SaveName As String
Set wApp = New Word.Application
With wApp
'Make word visible
.Visible = True
.Activate
.Documents.Add "C:\Users\MyDesktop\TemplateWordFile.dotx"
'paste supplier name in word
Sheets("Sheet1").Range("C1").Copy
.Selection.Goto what:=wdGoToBookmark, name:="SupplierName"
.Selection.PasteSpecial DataType:=wdPasteText
'Dynamic range
Dim Table1 As Worksheet
Dim Table2 As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set Table1 = Worksheets("Table 1")
Set Table2 = Worksheets("Table 2")
Set StartCell = Range("A1")
'Paste table 1 in word
Worksheets("Table 1").UsedRange
LastRow = Table1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Table1.Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table1"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
'Paste table 2 in word
Worksheets("Table 2").UsedRange
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Table 2").Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table2"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
'Save doc to a specific location and with a specific title
Dim name As String
name = "C:\Users\MyDesktop\Supplier\" & "DocName" & "_" & _
Sheets("Sheet1").Range("C1").Value & "_" & Sheets("Sheet1").Range("H1").Value & _
"_" & Format(Now, "yyyy-mm-dd") & ".docx"
.ActiveDocument.SaveAs2 Filename:=name
End With
End Sub
The problem is when the sheets are blank. I might only need one table (from sheet Table 1) and IF next sheet (Table 2) is empty, then I want VBA to do nothing and move to the next step. But then i get run time error 91 in this line of my code:
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
I have tried the "on error resume next" command, like this:
'Paste table 2 in word
Worksheets("Table 2").UsedRange
On Error Resume Next
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Table 2").Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table2"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
BUT in that case, it does bring to my word file an empty table (five lines, 10 rows that have nothing in, just the outline of a table), while I just want it to be blank/nothing appear on my word file.
Does anybody have any idea how this could be solved pretty please?
You could probably just add the If Not IsEmpty(Table1.UsedRange) Then statements to your code. This will prevent the code to run if the worksheet is completely empty. Please comment if you need more help.
Sub CreateBasicWordReport()
'Create word doc automatically
Dim wApp As Word.Application
Dim SaveName As String
Set wApp = New Word.Application
With wApp
'Make word visible
.Visible = True
.Activate
.Documents.Add "C:\Users\MyDesktop\TemplateWordFile.dotx"
'paste supplier name in word
Sheets("Sheet1").Range("C1").Copy
.Selection.Goto what:=wdGoToBookmark, name:="SupplierName"
.Selection.PasteSpecial DataType:=wdPasteText
'Dynamic range
Dim Table1 As Worksheet
Dim Table2 As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set Table1 = Worksheets("Table 1")
Set Table2 = Worksheets("Table 2")
Set StartCell = Range("A1")
'Paste table 1 in word
If Not IsEmpty(Table1.UsedRange) Then
LastRow = Table1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Table1.Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table1"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
End If
'Paste table 2 in word
If Not IsEmpty(Table2.UsedRange) Then
LastRow = Worksheets("Table 2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Table2.Range("A1:J" & LastRow).Copy
.Selection.GoTo what:=wdGoToBookmark, name:="Table2"
.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
End If
'Save doc to a specific location and with a specific title
Dim name As String
name = "C:\Users\MyDesktop\Supplier\" & "DocName" & "_" & _
Sheets("Sheet1").Range("C1").Value & "_" & Sheets("Sheet1").Range("H1").Value & _
"_" & Format(Now, "yyyy-mm-dd") & ".docx"
.ActiveDocument.SaveAs2 Filename:=name
End With
End Sub
Unfortunately I'm not able to comment on Fabian's answer, but his suggestion will probably solve your problem.
I just thought you should know that what your code is doing on "On Error Resume Next" is go to the next line, no matter if there is an error or not. Therefore, in order to tell the program to do something different in case there is an error, you'd have to verify if the error occurred and handle it.
you could avoid some code repetition and widen your code application by delegating tables cpying/pasting to a specific sub:
Sub PasteTables(docContent As Word.Range, numTables As Long)
Dim iTable As Long
Dim myRng As Range
With docContent
For iTable = 1 To numTables
Set myRng = Worksheets("Table " & iTable).UsedRange
If Not IsEmpty(myRng) Then
myRng.Copy
.Goto(what:=wdGoToBookmark, name:="Table" & iTable).PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdAlignRowLeft, DisplayAsIcon:=True
Application.CutCopyMode = False
End If
Next iTable
End With
End Sub
correspondingly your main code would shorten down to:
Option Explicit
Sub CreateBasicWordReport()
'Create word doc automatically
Dim wApp As Word.Application
Dim name As String
Set wApp = New Word.Application
sheets("Sheet01").Range("C1").Copy
With wApp.Documents.Add("C:\Users\MyDesktop\TemplateWordFile.dotx") '<-- open word document and reference it
'Make word visible
.Parent.Visible = True
.Parent.Activate
'paste supplier name in word
.content.Goto(what:=wdGoToBookmark, name:="SupplierName").PasteSpecial DataType:=wdPasteText
Application.CutCopyMode = False '<-- it's always a good habit to set it after pasting has taken place
'paste tables
PasteTables .content, 2 '<-- call your specific Sub passing the referenced document content and "2" as the maximum number of tables to loop through
'Save doc to a specific location and with a specific title
name = "C:\Users\MyDesktop\Supplier\" & "DocName" & "_" & _
sheets("Sheet1").Range("C1").Value & "_" & sheets("Sheet1").Range("H1").Value & _
"_" & Format(Now, "yyyy-mm-dd") & ".docx"
.ActiveDocument.SaveAs2 Filename:=name
End With
End Sub
I am a VBA newb and am having an extremely difficult time trying to write some code for this solution. Any help would be greatly appreciated!
Within MS Word, I need to look in one Excel workbook across a worksheet and copy/paste the data that fits my criteria into a two-column table:
Start in Row 6 of the worksheet, look within range D6:M6. If D6:M6 is blank, then go to the next row. If any cell in D6:M6 has data, copy the data from C6 and paste it in the first row of a table (preferably merged across two columns). Then, copy the data from Row 1 of the column that has data and paste it into the table's next row (1st column). Then, copy the data from the cell that has data and paste that into the 2nd column.
Basically, if there is data, the first row of a table will come from column C of the row that has data, the next row's first column will come from Row 1 of the column that has data, and the 2nd column of the second row will come from the cell that has data within that same column.
Thank you for offering to help. Here's a hyperlink to a sample Excel file, and the very Amateurish code I've started to write within MS Word that only covers the first product:
Excel Sample File
Private Sub useVBinWord()
Dim workBook As workBook
Dim dataInExcel As String
Application.ScreenUpdating = False
Selection.TypeText Text:="Comments:"
Selection.TypeParagraph
Selection.TypeText Text:="Printed: " & Now
Selection.TypeParagraph
Set workBook = Workbooks.Open("C:\Users....xls", True, True)
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=100, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
dataInExcel = workBook.Worksheets("Top30 Comments").Range("C6").Formula
ActiveDocument.Tables(1).Cell(1, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("D1").Formula
ActiveDocument.Tables(1).Cell(2, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("D6").Formula
ActiveDocument.Tables(1).Cell(2, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("E1").Formula
ActiveDocument.Tables(1).Cell(3, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("E6").Formula
ActiveDocument.Tables(1).Cell(3, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("F1").Formula
ActiveDocument.Tables(1).Cell(4, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("F6").Formula
ActiveDocument.Tables(1).Cell(4, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("G1").Formula
ActiveDocument.Tables(1).Cell(5, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("G6").Formula
ActiveDocument.Tables(1).Cell(5, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("H1").Formula
ActiveDocument.Tables(1).Cell(6, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("H6").Formula
ActiveDocument.Tables(1).Cell(6, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("I1").Formula
ActiveDocument.Tables(1).Cell(7, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("I6").Formula
ActiveDocument.Tables(1).Cell(7, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("J1").Formula
ActiveDocument.Tables(1).Cell(8, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("J6").Formula
ActiveDocument.Tables(1).Cell(8, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("K1").Formula
ActiveDocument.Tables(1).Cell(9, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("K6").Formula
ActiveDocument.Tables(1).Cell(9, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("L1").Formula
ActiveDocument.Tables(1).Cell(10, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("L6").Formula
ActiveDocument.Tables(1).Cell(10, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("M1").Formula
ActiveDocument.Tables(1).Cell(11, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("M6").Formula
ActiveDocument.Tables(1).Cell(11, 2).Select
Selection.TypeText Text:=dataInExcel
workBook.Close True
Set workBook = Nothing
Application.ScreenUpdating = True
End Sub
You've picked a difficult project to start with! Here's my almost complete solution :
Sub ImportTable()
Dim AppExcel As Excel.Application ' link to Excel
Dim ExcelRange As Excel.Range ' range in worksheet to process
Dim ExcelData As Variant ' worksheet data as VBA array
Dim ExcelHeadings As Variant ' worksheet headings as VBA array
Dim FoundCol As Boolean ' a column found with data ***
Dim exCol As Integer ' Excel column (iterator)
Dim exRow As Integer ' Excel row (iterator)
Dim wdRow As Integer ' Word table row
' reference to open instance of Excel
Set AppExcel = GetObject(class:="Excel.Application")
' change this to create an instance and open the file
Set ExcelRange = AppExcel.ActiveSheet.UsedRange ' the spreadsheet data as a range
' change this to ensure we have the correct worksheet
' the following reads cells C6 to End into a VBA array (row,column)
ExcelData = ExcelRange.Offset(5, 2).Resize(ExcelRange.Rows.Count - 6, _
ExcelRange.Columns.Count - 2)
' the following reads the heading row starting at C1
ExcelHeadings = ExcelRange.Offset(0, 2).Rows(1)
' assumes we have a blank document in word
With ActiveDocument.Range
.InsertAfter "Comments:" & vbCrLf ' insert your document header
.InsertAfter "Printed: " & Now & vbCrLf & vbCrLf
End With
Selection.EndOf wdStory ' reposition selection at end
ActiveDocument.Tables.Add Selection.Range, 1, 2 ' create a 1 x 2 table
With ActiveDocument.Tables(1) ' use this table
.Style = "Table Grid" ' set the style (copied from your code)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
' the first row is left blank for you to insert a title
' perhaps you should make this row repeat on each page
wdRow = 2 ' we will fill from row 2 which doesn't exist yet
For exRow = 1 To UBound(ExcelData, 1) Step 3 ' process every 3rd row
FoundCol = False ' mark 'not found' ***
For exCol = 2 To UBound(ExcelData, 2) ' test each column from D
If Trim(ExcelData(exRow, exCol)) <> "" Then ' if cell not empty
If Not FoundCol Then ' first filled column, write header
.Rows.Add ' add row for header
.Rows.Add ' add row for data (avoid problem with merged row)
.Rows(wdRow).Cells.Merge ' merge header row
.Rows(wdRow).Range.InsertAfter ExcelData(exRow, 1) ' add title from C
' this keeps the two rows together across page breaks
.Rows(wdRow).Range.ParagraphFormat.KeepWithNext = True
wdRow = wdRow + 1 ' row added
FoundCol = True ' header written
Else
.Rows.Add ' add row for data
' this keeps the two rows together across page breaks
.Rows(wdRow - 1).Range.ParagraphFormat.KeepWithNext = True
End If
' write heading from row 1
.Cell(wdRow, 1).Range.InsertAfter ExcelHeadings(1, exCol)
' write found data
.Cell(wdRow, 2).Range.InsertAfter ExcelData(exRow, exCol)
wdRow = wdRow + 1 ' row added
End If
Next exCol
Next exRow
End With
' don't forget to close the instance of Excel
End Sub
Read the comments, I've left you a bit of work to do!