Macro to export a table to Word

[Dzib]

Hi,


I've found this nice macro that works fine to copy/paste a table from Excel to Word:

Sub Export()

Dim wdApp As Object
Dim wd As Object

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wd = wdApp.Documents.Add
wdApp.Visible = True

Sheets("INV").Activate
Set Rng = ThisWorkbook.ActiveSheet.Range("A1:D200")
Rng.Copy
    With wd.Range
        .Collapse Direction:=wdCollapseStart
        .InsertParagraphAfter
        .Collapse Direction:=wdCollapseStart
        .PasteSpecial DataType:=1
            With .Find
                 .ClearFormatting
                 .Text = vbTab
                 .Replacement.ClearFormatting
                 .Replacement.Text = " "
                 .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
            End With
    End With
 End Sub

The problem is that the number of columns is fixed but not the number of rows, that's why I've gone until row 200 (I'll never go beyond).
So in the Word doc I have a bunch of empty lines in my table depending on the number of rows is my Excel table.


I've tried to integrate this macro inside my main macro but I can't get it to work, maybe because at first it was a Word macro, dunno if there are differences.

Sub DeleteEmptyCol2TableRows()
Application.ScreenUpdating = False
Dim Tbl As Table, i As Long
With ActiveDocument
  For Each Tbl In .Tables
    With Tbl
      For i = .Rows.Count To 1 Step -1
        If Len(.Cell(i, 2).Range.Text) = 2 Then .Rows(i).Delete
      Next i
    End With
  Next Tbl
End With
Application.ScreenUpdating = True
End Sub

It could work fine if I run this macro from Word after the Word doc has been created but I'd like to run all from Excel in one click.



Any idea?

[gmayor]

You had it almost right the first time, but you need to set the last row e.g. as follows. You also need to set the numeric values of the Word commands or they won't work with late binding. You haven't defined all your variables.

Option Explicit
Sub Export()

Dim wdApp As Object
Dim wd As Object
Dim xlSheet As Worksheet
Dim rng As Range
Dim LastRow As Long
Const wdReplaceAll As Long = 2
Const wdFindContinue As Long = 1

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    Set wd = wdApp.Documents.Add
    wdApp.Visible = True

    Set xlSheet = ActiveWorkbook.Sheets("INV")
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A1:D" & LastRow)
        rng.Copy
        With wd.Range
            .Collapse Direction:=1
            .InsertParagraphAfter
            .PasteSpecial DataType:=1
            With .Find
                .ClearFormatting
                .Text = vbTab
                .Replacement.ClearFormatting
                .Replacement.Text = " "
                .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
            End With
        End With
    End With
End Sub

[Dzib]

Works perfect! Thanks you so much