Excel to dynamic Word table - vba

Question

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

Answer 1

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!