Option Explicit

Private Sub wordMacro_start()
    Dim xcount As Long
    
    Dim xcol As Long, xrow As Long, xlng As Long
    Dim xstr As String
    Dim xdbl As Double
    
    'Tracks macro's speed
    Dim startTime As Date
    startTime = Now()
    
    Application.ScreenUpdating = False
    
    Dim tbl As Table
    Dim tbs As TabStop
    Dim rng As Range
    'Loops through every table
    For Each tbl In ActiveDocument.Tables
        xcount = xcount + 1
        Debug.Print xcount 'So I can read progress
        DoEvents 'So I have windows to pause execution
        
        'Loops through every column
        xcol = 1
        Do
            If xcol > tbl.Columns.Count Then Exit Do
            'Loops through every row
            xrow = 1
            Do
                If xrow > tbl.Rows.Count Then Exit Do
                
                'Skips when cell address doesn't exist within the table
                Set rng = Nothing
                On Error Resume Next
                Set rng = tbl.Cell(xrow, xcol).Range
                On Error GoTo 0
                If Not rng Is Nothing Then
                    'Tab stops and tab characters
                        'Loops through every tab stop within the cell
                        For Each tbs In rng.Paragraphs.TabStops
                            
                            'Gets starting position of next tab character
                            xlng = InStr(1, rng.Text, vbTab)
                            If xlng = 0 Then Exit For
                            
                            'Gets position of the tab stop + previous cell widths in the row
                            'Equals page position, sorta
                            xstr = rng.Text
                            xstr = Left(xstr, xlng - 1) & _
                                "{" & (pullRecursive_width(tbl, xrow, xcol) - _
                                PointsToInches(tbl.Cell(xrow, xcol).Width)) + _
                                PointsToInches(tbs.Position) _
                                 & "}" & _
                                Right(xstr, Len(xstr) - xlng)
                            'Replaces the tab character with the position number
                            rng.Text = xstr
                        Next tbs
                    
                    'Alignment
                        'Fortunately, cells with right alignments don't generate with tab characters
                        'If alignment is right
                        If tbl.Cell(xrow, xcol).Range.Paragraphs.Alignment = wdAlignParagraphRight Then
                            'If cell didn't generate as 'empty'
                            If tbl.Cell(xrow, xcol).Range.Text <> Chr(13) & _
                                Chr(7) Then
                                
                                'Gets this + all previous cell widths in the row
                                'Equals page position of the right margin of the cell
                                xdbl = pullRecursive_width(tbl, xrow, xcol)
                                xstr = "{" & _
                                    xdbl & "}" & _
                                    rng.Text
                                'Adds the position to the cell width
                                rng.Text = xstr
                            End If
                        End If
                End If
                
                xrow = xrow + 1
            Loop
            xcol = xcol + 1
        Loop
    Next tbl
    
    'Takes forever, sometimes start it and leave - so I have the macro save on finish
    ActiveDocument.Save
    
    'Describes macro's speed
    MsgBox "(" & Format(Now() - startTime, "Nn \mi\nute\s, Ss \se\co\n\d\s") & ")"
    
    Application.ScreenUpdating = True
End Sub

Private Function pullRecursive_width(sent_table As Table, _
    xrow As Long, _
    xcol As Long) As Double
    
    'Starts with current cell's width
    pullRecursive_width = PointsToInches(sent_table.Cell(xrow, xcol).Width)
    'If current cell is first cell, returns
    If xcol <= 1 Then Exit Function
    
    'If current cell isn't first cell, adds previous cell's width
    pullRecursive_width = pullRecursive_width + _
        pullRecursive_width(sent_table, xrow, xcol - 1)
End Function

Set rng = tbl.Cell(xrow, xcol).Range

Sub test_for_tab_inside_table()
    Dim r As Range
    Set r = ActiveDocument.Content
    With r.Find
        .ClearFormatting
        .Text = "^t"
        .Execute
        Do While .Found
            If r.Information(wdWithInTable) Then
                'Do the work
            End If
            .Execute
        Loop
    End With
End Sub

Sub Demo()
Application.ScreenUpdating = False
Dim t As Long, r As Long, c As Long, i As Long, Rng As Range, StrTmp As String
With ActiveDocument
  For t = 1 To .Tables.Count
    With .Tables(t)
      .AllowAutoFit = False
      With .Range.Font
        .Name = "Arial"
        .Size = 7
      End With
      .Rows.HeightRule = wdRowHeightExactly
      .Rows.Height = 10
      With .Range.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
      End With
      For r = 1 To .Rows.Count
        With .Rows(r)
          If .Cells.Count > 5 Then
            Set Rng = .Range
            Rng.Start = .Cells(6).Range.Start
            Rng.Cells.Delete
          End If
          Do While Split(.Cells(.Cells.Count).Range.Text, vbCr)(0) = ""
            .Cells(.Cells.Count).Delete
          Loop
          i = .Cells.Count
          If i < 5 Then
            Set Rng = .Range
            With .Range.Tables(1)
              If r < .Rows.Count Then .Split .Rows(r + 1)
              .Split .Rows(r)
              .Rows.Add
            End With
            Select Case i
              Case 1
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                .Cells(5).Range.Text = Split(StrTmp, vbTab)(2)
              Case 2
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 2).Range.Text, vbCr)(0)
                If InStr(StrTmp, vbTab) > 0 Then
                  .Cells(4).Range.Text = Split(StrTmp, vbTab)(UBound(Split(StrTmp, vbTab)) - 1)
                End If
                .Cells(5).Range.Text = Split(StrTmp, vbTab)(UBound(Split(StrTmp, vbTab)))
              Case 3
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
              Case 4
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 2).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(2).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 3).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(4).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 4).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(5).Range.Text = Split(StrTmp, vbTab)(0)
            End Select
            .Range.Tables(1).Rows(r).Range.Font.Bold = Not IsNumeric(Split(.Cells(.Cells.Count).Range.Text, vbCr)(0))
            With Rng
              .End = .Tables(2).Range.End + 1
              .Start = .Tables(2).Range.Start - 1
              .Delete
            End With
          End If
        End With
      Next
    End With
    DoEvents
  Next
End With
Application.ScreenUpdating = True
End Sub