Transfer Information from Excel Table to Pre-formatted Word Table

Sub Update_Active_Distribution()


    Dim dlg As FileDialog
    Dim strFile As String
    Dim oWkbCommPack As Object
    Dim oWksCommPack As Object
    Dim oExl As Object
    Dim vReturn As Object
    Dim oCell As Object
    
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
    
    If dlg.Show = -1 Then
        strFile = dlg.SelectedItems.Item(1)
    Else
        MsgBox "No file selected - Cancelled", vbExclamation, "Error"
        Exit Sub
    End If
    
    '// User must have the cursor in a table in the Word document.
    If Selection.Information(wdWithInTable) <> True Then
        MsgBox "The document cursor is not in a table - Cancelled.", vbExclamation, "Not in table"
        Exit Sub
    End If
    
    Set oExl = CreateObject("Excel.Application")
    oExl.Visible = True
    
    Set oWkbCommPack = oExl.workbooks.Open(strFile)
    
    '// Sheet name changed to Sheet1 - Edit as needed
    With oWkbCommPack.worksheets("Sheet1")
        .Activate
    End With
    
    On Error Resume Next
    
    '// Type parameter changed to 8 instead of 0. Gets rid of all the complications about R1C1 or A1  notation
    Set vReturn = oExl.Application.InputBox("Please select a range of cells.", "SelectARAnge Demo", _
        "Select Cell(s) or type address", Type:=8)
    
    If vReturn Is Nothing Then
        MsgBox "Nothing selected - Cancelled.", vbExclamation, "Cancelled"
    End If
    
    '// Check the current table has the same number of columns as the selected range in Excel - may not be needed but seemed 
    '//  sensible check.
    If ActiveDocument.Tables(ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count).Columns.Count = vReturn.Columns.Count Then
        
        '// Starting at row 2 in case Headers in row 1
        ActiveDocument.Tables(ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count).Cell(2, 1).Select
        
        '// For simplicity, each cell in the table is filled with the value in the Excel range
        '// and the cursor is moved 1 cell to the right. This will automatically add rows if needed
        '// but has the disadvantage of possibly adding a blank row at the end of the table.
        For Each oCell In vReturn
            Selection.TypeText oCell.Value
            Selection.MoveRight unit:=wdCell
        Next
    Else
        MsgBox "Mismatch in the number of columns in the table and the number of selected columns in Excel...", vbExclamation, "Error"
    End If
         
    oExl.Activeworkbook.Close SaveChanges:=0
    oExl.Quit
    
    Set oWksCommPack = Nothing
    Set oWkbCommPack = Nothing
    Set oExl = Nothing
    
End Sub

Sub Update_Active_Distribution()
     
    Dim dlg As FileDialog
    Dim strFile As String
    
    Dim oWkbCommPack As Object
    Dim oWksCommPack As Object
    Dim oExl As Object
    Dim oExlRange As Object
    Dim oCell As Object
    
    Dim wrdTable As Word.Table
    Dim wrdDataTable As Word.Table
    Dim wrdDoc As Word.Document
    
    Dim intCol As Integer
    Dim intRow As Integer
    
    Dim intCellsCount As Integer
    
    Dim bIsBlank As Boolean
    
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
     
    If dlg.Show = -1 Then
        strFile = dlg.SelectedItems.Item(1)
    Else
        MsgBox "No file selected - Cancelled", vbExclamation, "Error"
        Exit Sub
    End If
     
    Set wrdDoc = Application.ActiveDocument
    
     '// Either the document must only contain 1 table or the user must have placed the cursor in the table to be populated.
    If wrdDoc.Tables.Count > 1 And Selection.Information(wdWithInTable) <> True Then
        MsgBox "The document contains multiple tables, please place the cursor in the table to populate - Cancelled.", vbExclamation, "No table selected."
        Exit Sub
    Else
        '// If only 1 table then set a reference to it
        If wrdDoc.Tables.Count = 1 Then
            Set wrdTable = wrdDoc.Tables(1)
        Else
            '// Set a reference to the selected table
            Set wrdTable = wrdDoc.Tables(ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count)
        End If
    End If
    
    If wrdTable.Rows.Count < 3 Or wrdTable.Columns.Count < 3 Then
        MsgBox "The selected table does not contain the required minimum number of columns and/or rows.", vbExclamation, "Error"
        Exit Sub
    End If
    
    '// As mentioned, working with merged cells is a royal PITA. 
    '// Workaround - Split the table! They'll be re-combined later


    '// *** This assumes there are 2 Heading rows - one used as a 'banner' across most of the table
    '// *** and the Individual column headers below
    wrdTable.Rows(2).Select
    Selection.SplitTable
    Selection.MoveDown unit:=wdLine
    
    '// Sense check - just make sure cursor is in a table
    If Selection.Information(wdWithInTable) = False Then
        MsgBox "Logic error - cursor not in a table.", vbExclamation, "Error"
        Exit Sub
    Else
        '// Set a reference to this table
        Set wrdDataTable = wrdDoc.Tables(ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count)
    End If
    
    '// Start Excel, Load File and present to user to select range to use
    Set oExl = CreateObject("Excel.Application")
    oExl.Visible = True
     
    Set oWkbCommPack = oExl.workbooks.Open(strFile)
     
     '// Sheet name changed to Sheet1for testing - Edit as needed
    With oWkbCommPack.worksheets("Sheet1")
        .Activate
    End With
     
    On Error Resume Next
     
     '// Type parameter changed to 8 instead of 0. Gets rid of all the complications about R1C1 or A1  notation
    Set oExlRange = oExl.Application.InputBox("Please select a range of cells.", "SelectARAnge Demo", _
    "Select Cell(s) or type address", Type:=8)
     
    If oExlRange Is Nothing Then
        MsgBox "Nothing selected - Cancelled.", vbExclamation, "Cancelled"
    End If
    
    '// Delete any existing data in case extra rows retain information
    wrdDataTable.Select
    Selection.Delete


    '// Set number of columns equal the number of columns in the selected Excel range
    
    '// A simple loop until the number of columns match
    '// If the table already has the same number of columns, or more, then
    '// the loop will not be entered
    Do While wrdDataTable.Columns.Count < oExlRange.Columns.Count
        wrdDataTable.Range.Columns.Add
    Loop
    
    '// Same. but this time, remove any excess columns.
    Do While wrdDataTable.Columns.Count > oExlRange.Columns.Count
        wrdDataTable.Columns(wrdTable.Columns.Count).Delete
    Loop
    
    '// Go to Col 1 of Start Row
    wrdDataTable.Cell(1, 1).Select


     '// For simplicity, each cell in the table is filled with the value in the Excel range
     '// and the cursor is moved 1 cell to the right. This will automatically add rows if needed


     '// It also means the caption in Col 1 of the Start Row MUST come from Excel.


    '// There is a potential issue if individual cells are formatted. Adding columns will 
    '// assume the 'default' format.


    For Each oCell In oExlRange
        '// Using the TEXT property of the cell as this will contain the formatted
        '// value as displayed in Excel. Using the VALUE property will insert the
        '// underlying value. For example a VALUE might show as 34.5, but the
        '// formatted TEXT property displays $34.50
        Selection.TypeText oCell.Text
        Selection.MoveRight unit:=wdCell
        
    Next
    
    '// Remove any totally blank rows
    
    '// Loop backwards from last row. Stop at row 2, if it gets to there
    For intRow = wrdDataTable.Rows.Count To 2 Step -1
        
        '// Traverse the columns
        For intCol = 1 To wrdDataTable.Columns.Count
            
            '// If text in this cell is longer than 2 characters
            '// (Blank cells have some control chars - can't remember what exactly
            '// but irrelevant)
            If Len(wrdDataTable.Cell(intRow, intCol).Range.Text) > 2 Then
                bIsBlank = False
                '// Found something, so no point in continuing the loop
                Exit For
            Else
                '// Just set the flag to True and go around again
                bIsBlank = True
            End If
        Next
        
        '// Blank row found...?
        If bIsBlank Then
            '// delete it
            wrdDataTable.Rows(intRow).Delete
        Else
            '// Assuming any non blank cell means the last totally empty row has been found
            Exit For
        End If


    Next
    
    '// Set vertical alignment to center (My preference only)
    wrdDataTable.Select
    With Selection
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        .Font.Bold = False
    End With
    
    '// Bold first row and first column
    wrdDataTable.Rows(1).Select
    Selection.Font.Bold = True
    
    wrdDataTable.Columns(1).Select
    Selection.Font.Bold = True
    
    '// Go back to first row of data table and move up one line
    '// This should be the Paragraph marker inserted when the tables
    '// were split
    wrdDataTable.Rows(1).Select
    With Selection
        .MoveUp unit:=wdLine
        .Delete
    End With
    
    '// Resize both tables to Window
    wrdDataTable.AutoFitBehavior (wdAutoFitWindow)
    wrdTable.AutoFitBehavior (wdAutoFitWindow)
    
    '// Set width of Column 1 in Original table to current width of Col 1 in Data table
    wrdTable.Cell(1, 1).Width = wrdDataTable.Cell(1, 1).Width
    
    '// Set width of Column 2 in Original table to match the remaining width of the data table
    wrdTable.Cell(1, 2).Width = wrdDataTable.Cell(1, 1).Width * (wrdDataTable.Columns.Count - 1)
    
    '// Because the two tables can be 'matched' as regards position and column widths, and now have
    '// no paragraph marker between them, Word should automatically merge them into 1 table.


    '// Clean up and exit
    oExl.Activeworkbook.Close SaveChanges:=0
    oExl.Quit
     
    Set oWksCommPack = Nothing
    Set oWkbCommPack = Nothing
    Set oExl = Nothing
     
    Set wrdTable = Nothing
    Set wrdDataTable = Nothing
    Set wrdDoc = Nothing
    
End Sub