excel vba to remove first row from each table in word document

[gbrew584]

I am hoping someone can help me as i have been working on this project for three days. I am at my wits end. Forgive me if this post is in the wrong forum but I'm not sure if it should be Word or Excel.

I have a word document with tables, and the number of tables varies each week. In the tables there are three columns. There are headers in the first two rows of the tables. The first two rows in the first column are merged. I want to remove the headers and combine the tables and make on big table and then copy and past to excel. I would like to do all this from excel.

In my code, I am stuck at Sub Delete_Header_first_row. The code can find the number of tables in the document but it will not highlight or delete. When i run the routine the code bypasses the selecting and deleting and goes straight to the end.

The code is in an excel 2010 file, and it is accessing the a word 2010 file. I don't have much experience with vba.



(I am missing the rest of the code at the end of Sub OpenDoc that will fire Sub RemoveSectionBreaks, but I haven't got far enough into the program to worry about that yet.)

I was able to get Sub Delete_Header_first_row to run when it was in word but once i moved it to excel, I cannot get it to work.

If anyone can tell me what I am missing I would appreciate it.

  Option Explicit
  Dim Get_File As String
  Dim objWord As Object
  Dim objDoc As Object
  Dim objSelection As Object
  Dim i As Long
  Dim wdCharacter As Boolean
  Dim wdExtend As Boolean
   
  Sub OpenDoc()
      
        'instructions to user
      MsgBox ("Please select the Word Document you would like to convert.")
      ' Display Open dialog
      With Application.FileDialog(1) ' msoFileDialogOpen
          .Filters.Clear
          .Filters.Add "Word documents", "*.doc*"
          If .Show Then
              Get_File = .SelectedItems(1)
          Else
              MsgBox "No document selected.", vbExclamation
              Exit Sub
          End If
      End With
      On Error Resume Next
      RUsure = MsgBox("Is this the correct Word Document?" & vbNewLine & Get_File, vbYesNo)
      If RUsure = vbYes Then
      ' See if Word is already running; if not, start it
      Set objWord = GetObject(Class:="Word.Application")
      If objWord Is Nothing Then
          Set objWord = CreateObject(Class:="Word.Application")
          If objWord Is Nothing Then
              MsgBox "Can't start Word.", vbExclamation
              Exit Sub
          End If
          End If
          
      End If
      ' Open document
      Set objDoc = objWord.Documents.Open(Filename:=Get_File) 'opens the word document
      objWord.Visible = True 'makes ms word application visible
      objDoc.Select
      Set objSelection = objWord.Selection
      Delete_Header_first_row
            
        End Sub
   
  Sub Delete_Header_first_row()
          Dim tblcnt As Integer
          With objDoc
          tblcnt = objDoc.Tables.Count
      For i = 1 To objDoc.Tables.Count
      objWord.Tables(i).Cells(1, 1).Select
      objWord.Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
      objDoc.Rows.Delete
      
      Next i
      End With
      RemoveSectionBreaks
      DeleteEmptyParas
      objDoc.Tables(1).Range.Copy
   
  End Sub
  Sub RemoveSectionBreaks()
      Dim rg As Range
      Set rg = activedocument.Range
      With rg.Find
          .Text = "^b" ' section break
          .Wrap = wdFindStop
          While .Execute
              rg.Delete
          Wend
      End With
  End Sub
  Sub DeleteEmptyParas()
   
  Dim MyRange As Range, oTable As Table, oCell As Cell
   
  Set MyRange = activedocument.Paragraphs(1).Range
  If MyRange.Text = vbCr Then MyRange.Delete
   
  Set MyRange = activedocument.Paragraphs.Last.Range
  If MyRange.Text = vbCr Then MyRange.Delete
   
  For Each oTable In activedocument.Tables
      #If VBA6 Then
          'The following is only compiled and run if Word 2000 or 2002 is in use
           'It speeds up the table and your code
           oTable.AllowAutoFit = False
      #End If
   
      'Set a range to the para following the current table
       Set MyRange = oTable.Range
      MyRange.Collapse wdCollapseEnd
      'if para after table empty, delete it
      If MyRange.Paragraphs(1).Range.Text = vbCr Then
          MyRange.Paragraphs(1).Range.Delete
      End If
   
      Next oTable
   
  End Sub

[gmayor]

You are nearly there, but you are working in Excel and confusing Word VBA commands with those from Excel. If you are using LateBinding to Word, you cannot use any commands that are prefixed wd, so you must use their numeric equivalents, and Word components such as ranges and tables should be defined as objects. Then you get something like the following which will work from Excel.

Option Explicit
Private Get_File As String
Private objWord As Object
Private objDoc As Object
Private RUSure As Long

Sub OpenDoc()
'instructions to user
    MsgBox ("Please select the Word Document you would like to convert.")
    ' Display Open dialog
    With Application.FileDialog(1)        ' msoFileDialogOpen
        .Filters.Clear
        .Filters.Add "Word documents", "*.doc*"
        If .Show Then
            Get_File = .SelectedItems(1)
        Else
            MsgBox "No document selected.", vbExclamation
            Exit Sub
        End If
    End With
    On Error Resume Next
    RUSure = MsgBox("Is this the correct Word Document?" & vbNewLine & Get_File, vbYesNo)
    If RUSure = vbYes Then
        ' See if Word is already running; if not, start it
        Set objWord = GetObject(Class:="Word.Application")
        If objWord Is Nothing Then
            Set objWord = CreateObject(Class:="Word.Application")
            If objWord Is Nothing Then
                MsgBox "Can't start Word.", vbExclamation
                Exit Sub
            End If
        End If

    End If
    ' Open document
    Set objDoc = objWord.Documents.Open(Filename:=Get_File)        'opens the word document
    objWord.Visible = True        'makes ms word application visible
    Delete_Header_first_row objDoc
    RemoveSectionBreaks objDoc
    DeleteEmptyParas objDoc
    objDoc.Tables(1).Range.Copy
End Sub

Sub Delete_Header_first_row(odoc As Object)
Dim oTable As Object
For Each oTable In odoc.Range.Tables
    oTable.Rows(1).Delete
Next oTable
End Sub

Sub RemoveSectionBreaks(odoc As Object)
Dim rg As Object
    Set rg = odoc.Range
    With rg.Find
        .Text = "^b"        ' section break
        .Wrap = 0
        While .Execute
            rg.Delete
        Wend
    End With
End Sub

Sub DeleteEmptyParas(odoc As Object)

Dim MyRange As Object, oTable As Object, oCell As Object
    Set MyRange = odoc.Paragraphs(1).Range
    If Len(MyRange) = 1 Then MyRange.Delete

    Set MyRange = odoc.Paragraphs.Last.Range
    If Len(MyRange) = 1 Then MyRange.Delete

    For Each oTable In odoc.Tables
        #If VBA6 Then
            'The following is only compiled and run if Word 2000 or 2002 is in use
            'It speeds up the table and your code
            oTable.AllowAutoFit = False
        #End If

        'Set a range to the para following the current table
        Set MyRange = oTable.Range
        MyRange.Collapse 0
        'if para after table empty, delete it
        If Len(MyRange.Paragraphs(1).Range) = 1 Then
            MyRange.Paragraphs(1).Range.Delete
        End If
    Next oTable
End Sub

[gbrew584]

Oh wow, I didn't even think to use table as object. this is great!!, thank you so very very much for your help. I don't have time to try the new code today but I hope to try it this evening. thanks again for your help and I'll keep you posted as to my progress. I just wish I knew more about VBA so I could help others, but I've got a lot to learn before that happens. Thanks again!!

[gbrew584]

Graham- I tried the code you supplied but i'm having the same problem. Whenever the code reaches the Sub_delete_header_first_row, it doesn't delete anything and it just jumps to the end and stops. it doesn't even run Removesectionbreaks or deleteemptyparas.

Just for my own understanding, How does the code know what odoc and otable are when they have not been set?

thanks for trying. i guess i'm not smart enough to figure this out.

[gmayor]

The macro as supplied addresses every table in the document body. It works with a document with multiple tables as you described. If it isn't working for you I would need to see a copy of the document you are processing to establish why.

You can either post it to the forum as an attachment or send it to my e-mail supportATgmayor.com (change AT to @) and put your forum username in the subject line or the message will be discarded.

[gbrew584]

I have sent an email with the document attached. I suspect that the code is having issues with the merged cell but I don't know enough about VBA, yet, to know if that is the cause or how to resolve it.

Thanks for taking the time to try and help me.

[gmayor]

The document contained a mishmash of Excel and Word code. As were are working from Word, the code needs to be in a template (if it is just for you, the normal template will work) and should be something like the following. This will open a new Excel workbook and paste the data with the same cell content as it has in the processed Word table.

Option Explicit

Sub Process_Word_File()
Dim xlApp As Object
Dim xlBook As Object
Dim wdDoc As Document
Dim wdFileName As Variant
Dim i As Long

    wdFileName = BrowseForFile("Select the Word document to process", False)
    If wdFileName = "" Then GoTo lbl_Exit
    Set wdDoc = Documents.Open(wdFileName)
    Delete_Header_first_row
    RemoveSectionBreaks
    DeleteEmptyParas
    wdDoc.Tables(1).Range.Copy

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Add
    xlApp.Visible = True
    xlBook.sheets(1).Range("A1").PasteSpecial ("HTML")
    With xlBook.sheets(1).usedrange
        .VerticalAlignment = -4160
        .HorizontalAlignment = -4131
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = -1
        .ShrinkToFit = False
        .ReadingOrder = -5002
        .MergeCells = False
        .Columns.AutoFit
    End With
    'wdDoc.Close 0
lbl_Exit:
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set wdDoc = Nothing
    Exit Sub
End Sub

Sub Delete_Header_first_row()
Dim oTable As Object
    For Each oTable In ActiveDocument.Range.Tables
        oTable.Cell(1, 1).Select
        Selection.MoveRight Unit:=1, Count:=2, Extend:=1
        Selection.Rows.Delete
    Next oTable
lbl_Exit:
    Set oTable = Nothing
    Exit Sub
End Sub

Sub RemoveSectionBreaks()
Dim oRng As Object
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Text = "^b"        ' section break
        .Wrap = 0
        While .Execute
            oRng.Delete
        Wend
    End With
lbl_Exit:
Set oRng = Nothing
    Exit Sub
End Sub

Sub DeleteEmptyParas()
Dim oPara As Object
    For Each oPara In ActiveDocument.Range.Paragraphs
        If Not oPara.Range.Information(12) Then
            If Len(oPara.Range) = 1 Then oPara.Range.Delete
        End If
    Next oPara
lbl_Exit:
    Set oPara = Nothing
    Exit Sub
End Sub

Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

[gbrew584]

I've been out of town and haven't had a chance to try your corrections. Thanks again for helping me. I am wondering, Is there any way I can do what I want using Excel as the host? Don't get me wrong, I'm willing to learn more about Word, its just that being an Accountant, I am more comfortable using Excel.

[gmayor]

It probably could be redeveloped to work from Excel, but frankly as it is easier to process the document from Word. Word and Excel VBA are inherently similar so you shouldn't have any difficulty running the code from Word - http://www.gmayor.com/installing_macro.htm

[gbrew584]

Thanks Grahm for you help. I have been experimenting with the code you provided and it works. Many thanks for helping me organize my code. I was wondering how I get control of the excel workbook so that i can add a couple of columns in between A and B and B and C, so that i have a column of data empty column, column of data, empty column.

I have tried setting up a sub called insertcolumn, and I tried using getobject and createobject and just about everything inbetween, but I just can't seem to get control over Excel. I hate to ask, but could you give me a hint on what I need to do?

[gmayor]

If you are referring to the earlier macro, this addresses the workbook with the variable xlBook. To insert columns between A & B and between B & C locate the line

xlBook.sheets(1).Range("A1").PasteSpecial ("HTML")

and after it add the lines

xlBook.sheets(1).Range("B1").EntireColumn.Insert
xlBook.sheets(1).Range("D1").EntireColumn.Insert

[gbrew584]

Thanks for taking the time to help me. I tried your suggestion but i get the message object doesn't support this property or method. I've tried moving the code to after the End With statement but I get the same results.

I've tried changing xlbook to Worksheets, i changed sheets (1), i added xlapp in front of xlbook, I tried xlbook.sheets (1).Insert.Column and about 20 other variations and combinations of commands but nothing seems to work.

does the workbook need to have a name (be saved) before it will work?
Do I need to activate a Library in my Preferences? I'm lost.

I don't know if this matters, but when I hover my mouse over the declaration for xlbook nothing shows, but when i hover over xlapp it shows ="Microsoft Excel". For some reason it seems to get hung up on xlbook?

Do you have any other suggestions I can try?

[gbrew584]

anyone else have any suggestions I can try?

[Guessed]

It appears that Graeme is the only one that has seen your document and workbook so it might be difficult for others to chime in with help.

If xlBook.sheets(1).Range("A1").PasteSpecial ("HTML") works successfully then adding the suggested lines immediately after that should still have the xlBook.sheets(1) object available to you.

If that code to add a column is failing then perhaps there are merged cells that are causing the issue.

[gbrew584]

thanks Andrew, very much, for trying to help me, i am still stuck. sorry for the delayed reply but i was giving up on the possibility of someone helping me. the word document had merged cell in the tables but Graham's code helped me get rid of them. so i'm not sure what else it could be. Thanks for the tip. I will try again and see how it turns out. Thanks