Sub Process_Word_File()
 Dim xlApp As Object
 Dim xlbook As Object
 Dim wdDoc As Document
 Dim wdFileName As Variant
 Dim i As Long
 Dim RegularHours As String, OtherHours As String, HoursCode As String, EEName As String, EENumber As String
 Dim DeductionLabels As String
 Dim FormulaPasteArea As Object, FormulaPasteAreaYTD As Object
 Dim ix As Long, ix2 As Long
 Dim LastRow As Long, lrow2 As Long
 Dim lcol As Long
 Dim Rcount As Long
 
 
  Const LK1 As String = "AccVAC"
  Const LK2 As String = "Delete"
  Const SickFactor = "0.03846"
  Const xlUp As Long = -4162
  Const xlDown As Long = -4121
  Const xltoLeft As Long = -4159
  Const xltoRight As Long = -4161
  Const xlPasteValues As Long = -4163
  Const xlValues As Long = -4163
  Const xldelimited As Long = 1
  Const xlDoubleQuote As Long = 1
  Const xlCellTypeFormulas = -4123
  Const xlpart = 2
  Const xlbyrows = 1
  Const xlprevious = 2
  Const xlformulas = 5
  
    wdFileName = BrowseForFile("Select the Word document to process", False)
    If wdFileName = "" Then GoTo lbl_Exit
    Set wdDoc = Documents.Open(wdFileName)
    
    ' clean the word document of all text keeping the tables, and combine the tables and replace spaces and tabs with special characters so it can be separated into columns
    
    RemoveLines
    RemoveParagraphs
    DeleteHeaderRow
    ReplaceTabs
    ReplaceSpace
    
    'copy the word table and paste into excel.
    
    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
    
   
    
    
  
     
    'With xlbook.sheets(2).usedrange
        '.VerticalAlignment = -4160
        '.HorizontalAlignment = -4131
        '.WrapText = False
        '.Orientation = 0
       ' .AddIndent = False
        '.IndentLevel = -1
       ' .ShrinkToFit = False
       ' .ReadingOrder = -5002
        '.MergeCells = False
        '.Columns.AutoFit
   ' End With
  
     
     RegularHours = "=IF(ISNUMBER(SEARCH(""@"",G1)),LEFT(G1,SEARCH(""@"",G1)-1),IF(ISNUMBER(SEARCH(""(("",G1)),0,LEFT(G1,LEN(G1))))"
     'RegularHours = "=IF(ISNUMBER(SEARCH("@",H2)),LEFT(H2,SEARCH("@",H2)-1),IF(ISNUMBER(SEARCH("((",H2)),0,LEFT(H2,LEN(H2))))"
     OtherHours = "=IF(ISERROR(SEARCH(""(("",G1)),0,IF(AND(ISNUMBER(SEARCH(""(("",G1)),ISNUMBER(SEARCH(""@"",G1))),MID(G1,SEARCH(""@"",G1)+1,SEARCH(""(("",G1)-1-SEARCH(""@"",G1)),LEFT(G1,SEARCH(""(("",G1)-1)))"
     'OtherHours = "=IF(ISERROR(SEARCH("((",H2)),0,IF(AND(ISNUMBER(SEARCH("((",H2)),ISNUMBER(SEARCH("@",H2))),MID(H2,SEARCH("@",H2)+1,SEARCH("((",H2)-1-SEARCH("@",H2)),LEFT(H2,SEARCH("((",H2)-1)))"
     HoursCode = "=IF(ISERROR(SEARCH(""(("",G1)),"""",RIGHT(G1,LEN(G1)-SEARCH(""(("",G1)-1))"
          'HoursCode = "=IF(ISERROR(SEARCH("((",H2)),"",RIGHT(H2,LEN(H2)-SEARCH("((",H2)-1))"
     
     EENumber = "=IF(ISERROR(SEARCH(""EE#"",a2)),"""",RIGHT(a2,4))"
     EEName = "=IF(ISERROR(SEARCH("","",a1)),"""",a1)"
     DeductionLabels = "=CONCATENATE(Q1,R1)"
    
   xlbook.Application.DisplayAlerts = False
       
       ' split employee names and department numbers and payrates into three columns using "@" as delimiter
   
   xlbook.sheets(1).Range("b:c").EntireColumn.Insert
      xlbook.sheets(1).Range("a:a").TextToColumns , Destination:=xlbook.sheets(1).Range("a1"), DataType:=xldelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
          Semicolon:=False, Comma:=False, Space:=False, Other:=True, otherchar:="@", _
           FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
           
           'Split codes for hours into its own column using "Space" as the delimiter
           
   xlbook.sheets(1).Range("e:e").EntireColumn.Insert
      xlbook.sheets(1).Range("d:d").TextToColumns , Destination:=xlbook.sheets(1).Range("d1"), DataType:=xldelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
          Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
           FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
           
           'split hours into regular and other using "@" as the delimiter
           
               
   xlbook.sheets(1).Range("e:e").EntireColumn.Insert
      xlbook.sheets(1).Range("d:d").TextToColumns , Destination:=xlbook.sheets(1).Range("d1"), DataType:=xldelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
          Semicolon:=False, Comma:=False, Space:=False, Other:=True, otherchar:="@", _
           FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
           
           'insert columns for formulas to seperate reqular and other dollars.
           
    xlbook.sheets(1).Range("h:j").EntireColumn.Insert
    
           'inster fourmulas for regular and other dollars.
           
          xlbook.sheets(1).Range("h1").Formula = RegularHours  'Column 8
          xlbook.sheets(1).Range("i1").Formula = OtherHours  'Column 9
          xlbook.sheets(1).Range("j1").Formula = HoursCode 'Column 10
          
          'Split tax amounts and codes into seperate columns based on "(" delimiter
          
    xlbook.sheets(1).Range("m:m").EntireColumn.Insert
      xlbook.sheets(1).Range("l:l").TextToColumns , Destination:=xlbook.sheets(1).Range("l1"), DataType:=xldelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
          Semicolon:=False, Comma:=False, Space:=False, Other:=True, otherchar:="(", _
          FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
          
          'split deductions and deduction codes into columns based on "Space" delimiter
                           
   xlbook.sheets(1).Range("o:o").EntireColumn.Insert
      xlbook.sheets(1).Range("n:n").TextToColumns , Destination:=xlbook.sheets(1).Range("n1"), DataType:=xldelimited, _
          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
          Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
          FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
          
   xlbook.Application.DisplayAlerts = True
   
   xlbook.sheets(1).Range("b:c").EntireColumn.Insert
   xlbook.sheets(1).Range("c1").Formula = EENumber  'Column 3
   xlbook.sheets(1).Range("b1").Formula = EEName  'Column 2
   xlbook.sheets(1).Range("s1").Formula = EEName 'copy entire worksheet and replace formulas with data
   
   'find the last row used in the worksheet
   
    With xlbook.sheets(1)
     If Application.worksheetfunction.CountA(.Cells) <> 0 Then  'took out application and added xlbook
         LastRow = .Cells.Find(What:="*", _
                      After:=xlbook.sheet(1).Range("A1"), _
                      Lookat:=xlpart, _
                      LookIn:=xlformulas, _
                      SearchOrder:=xlbyrows, _
                      SearchDirection:=xlprevious, _
                      MatchCase:=False).Row
     Else
         LastRow = 1
     End If
  End With

  MsgBox LastRow
   
   xlbook.sheets(1).Range("a:b").Copy
   xlbook.sheets(1).Range("A:b").PasteSpecial Paste:=xlValues
   
     
   'fill worksheet with ee name and ee number
   
  With xlbook.sheets(1).usedrange
    .Columns("A:A").Select
    .Selection.SpecialCells(xlCellTypeFormulas, 1).Select
    .Selection.FormulaR1C1 = "=R[-1]C"
    .Columns("A:A").Select
    .Columns("A:A").Copy
    .Columns("A:A").Select
    .Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Application.CutCopyMode = False
    
 .Columns("B:B").Select
    .Selection.SpecialCells(xlCellTypeFormulas, 1).Select
    .Selection.FormulaR1C1 = "=R[-1]C"
    .Columns("B:B").Select
    .Columns("B:B").Copy
    .Columns("B:B").Select
    .Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Application.CutCopyMode = False
    End With
    
       
    'insert row for headers
   
   'xlbook.Sheets(1).Range("a1").Entirerow.Insert
   
   
  'HoursWorkedCurrent As String
 'Dim SickHoursAccruedCurrent As String, SickHoursTakenCurrent As String, VacationHoursAccruedCurrent As String, VacationHoursTakenCurrent As String
 'Dim SickHoursAccruedYTD As String, SickHoursTakenYTD As String, SickHoursAvailableYTD As String, VacationHoursAccruedYTD As String
 'Dim VacationHoursTakenYTD As String, VacationHoursAvailableYTD As String
  
  
     
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 ReplaceTabs()
'Dim oRng As Object


  'Set oRng = ActiveDocument.Range
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = "@"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = True
        .MatchWholeWord = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub
Sub ReplaceSpace()
'Dim oRng As Object


  'Set oRng = ActiveDocument.Range
    With Selection.Find
        .Text = Space(2)
        .Replacement.Text = "("
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = True
        .MatchWholeWord = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub
Sub RemoveHeader()
Dim oRng As Object
Dim i As Long
Dim HeaderList

  HeaderList = Array("Employee", "Hours", "Earnings", "Gross", "Taxes", "Deductions", "Net Pay", "^p^p")
  
  For i = 0 To UBound(HeaderList)
  
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Text = HeaderList(i)
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        
        .Wrap = 0
        While .Execute
            oRng.Delete
        Wend
    End With
    Next
lbl_Exit:
Set oRng = Nothing
    Exit Sub
End Sub
Sub Removetables()
Dim oTable As Table
For Each oTable In ActiveDocument.Tables
oTable.Delete
Next oTable
End Sub

Sub RemoveParagraphs()
Dim oPara As Paragraph
'Dim answer
For Each oPara In ActiveDocument.Paragraphs
'oPara.Range.Select
'answer = MsgBox(oPara.Range.Information(wdWithInTable))
If Not oPara.Range.Information(wdWithInTable) Then  'checks to see if paragraph is in table, if it is it skipps to the next paragraph, if its not it delets paragraph
oPara.Range.Delete
End If
Next oPara

End Sub


Sub RemoveLines()

  ActiveDocument.Shapes.SelectAll
    Selection.Delete
    
    
End Sub
Sub DeleteHeaderRow()
    Dim sText As String

    sText = "RATE"
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = sText
        .MatchCase = True
        .MatchWholeWord = True
        .Wrap = wdFindContinue
    End With
    Do While Selection.Find.Execute
        If Selection.Information(wdWithInTable) Then
            Selection.Rows.Delete
        End If
    Loop
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() ' delete empty paragraphs
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
'End Function

 Sub DeleteTxtbox()
Dim oShp As Word.Shape
Dim i As Long
For i = ActiveDocument.Shapes.Count To 1 Step -1
Set oShp = ActiveDocument.Shapes(i)
If oShp.Type = msoTextBox Then
oShp.Delete
End If
Next i
End Sub