Excel to dynamic Word table

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!