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.
Code:
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