Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, TblSrc As Table, TblTgt As Table, Rng As Range
Dim StrClnt As String, StrProj As String, StrRdDt As String, StrLocn As String, StrCRef As String
Dim StrISO As String, StrDia As String, StrWeld As String, StrID As String
Dim StrMtrl As String, StrActNo As String, StrReqNo, Result As String, i As Long, j As Long
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add
With DocSrc
  Set TblSrc = .Range.Tables(1)
  j = -Int(-(TblSrc.Rows.Count - 1) / 3 * 2)
  'Get the ClientName, ProjectName, RadDate, Location, ClientRef
  With .Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1)
    Set Rng = .Cell(1, 1).Range
    With Rng
      .End = .End - 1
      StrClnt = .Text
    End With
    Set Rng = .Cell(1, 4).Range
    With Rng
      .End = .End - 1
      StrProj = .Text
    End With
    Set Rng = .Cell(2, 2).Range
    With Rng
      .End = .End - 1
      StrRdDt = .Text
    End With
    Set Rng = .Cell(3, 2).Range
    With Rng
      .End = .End - 1
      StrLocn = .Text
    End With
    Set Rng = .Cell(4, 4).Range
    With Rng
      .End = .End - 1
      StrCRef = .Text
    End With
  End With
End With
With DocTgt
  'Do the page setup
  With .PageSetup
    .PaperSize = wdPaperA4
    .LeftMargin = CentimetersToPoints(0.72)
    .RightMargin = CentimetersToPoints(0.72)
    .BottomMargin = CentimetersToPoints(0)
    .TopMargin = CentimetersToPoints(0.45)
  End With
  'Create the output table
  Set TblTgt = .Tables.Add(Range:=.Range, NumRows:=j, NumColumns:=3, _
    DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow)
  With TblTgt
    'Format the output table
    .Rows.HeightRule = wdRowHeightExactly
    .Rows.Height = CentimetersToPoints(2.38)
    .Columns.Width = CentimetersToPoints(6.57)
    .Borders.Enable = False
    With .Range
      With .ParagraphFormat
        .TabStops.Add Position:=CentimetersToPoints(4.75), Alignment:=wdAlignTabLeft
        .SpaceBefore = 0
        .SpaceAfter = 0
      End With
      With .Font
        .Size = 9
        .Name = "Calibri"
      End With
    End With
    With .Range
      For i = 2 To TblSrc.Rows.Count
        With TblSrc
          'Get the ISO Num, Diameter, Weld No, Wr I.D, Material, Actual Wire No, Required Wire No, Result
          Set Rng = .Cell(i, 1).Range
          With Rng
            .End = .End - 1
            StrISO = .Text
          End With
          Set Rng = .Cell(i, 2).Range
          With Rng
            .End = .End - 1
            StrDia = .Text
          End With
          Set Rng = .Cell(i, 3).Range
          With Rng
            .End = .End - 1
            StrWeld = .Text
          End With
          Set Rng = .Cell(i, 4).Range
          With Rng
            .End = .End - 1
            StrID = .Text
          End With
          Set Rng = .Cell(i, 5).Range
          With Rng
            .End = .End - 1
            StrMtrl = .Text
          End With
          Set Rng = .Cell(i, 6).Range
          With Rng
            .End = .End - 1
            StrActNo = .Text
          End With
          Set Rng = .Cell(i, 7).Range
          With Rng
            .End = .End - 1
            StrReqNo = .Text
          End With
          Set Rng = .Cell(i, 8).Range
          With Rng
            .End = .End - 1
            Result = .Text
          End With
        End With
        Set Rng = .Cells((i - 1) * 2 - 1).Range
        With Rng
          .End = .End - 1
          .Text = StrRdDt & Chr(11) & StrCRef & Chr(11) & _
          "ISO NUM: " & StrISO & vbTab & "DIA: " & StrDia & Chr(11) & _
          "WELD NO: " & StrWeld & vbTab & "WR ID: " & StrID
        End With
      Next
    End With
  End With
  With .Range.Find
    .ClearFormatting
    With .Replacement
      .ClearFormatting
      .Font.Bold = True
      .Font.Underline = wdUnderlineSingle
      .Text = "^&"
    End With
    .Forward = True
    .Format = True
    .MatchCase = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .MatchAllWordForms = False
    .Text = "ISO NUM:"
    .Execute Replace:=wdReplaceAll
    .Text = "DIA:"
    .Execute Replace:=wdReplaceAll
    .Text = "WELD NO:"
    .Execute Replace:=wdReplaceAll
    .Text = "WR ID:"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub