Sub Demo()
Application.ScreenUpdating = False
Dim GigNum As String, GigName As String, GigDate As String, GigLoc As String, GigPost As String, GigTime As String, GigFile As String
Dim DocSrc As Document, DocRef As Document, DocTgt As Document, Rng As Range, r As Long, p As Long, Fld As Field, StrKey as String
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the Song Book": .AllowMultiSelect = False
  .Filters.Clear: .Filters.Add "Documents", "*.doc; *.docx; *.docm", 1
  .InitialFileName = "D:\Documents\MJH-20\MJH-Music\LotSU\LotSU Songbooks\"
  If .Show = -1 Then
    Set DocRef = Documents.Open(.SelectedItems(1), ReadOnly:=True, Visible:=False, AddToRecentFiles:=False)
  Else
    MsgBox "No Song Book selected. Exiting", vbExclamation: Exit Sub
  End If
End With
Set DocSrc = Documents.Open(FileName:="C:\Users\" & Environ("Username") & "\Desktop\SetListCreator.docx", ReadOnly:=True, Visible:=False, AddToRecentFiles:=False)
Set DocTgt = Documents.Add
With DocSrc
  With .Tables(1)
    GigNum = Split(.Cell(1, 1).Range.Text, vbCr)(0)
    GigName = Split(.Cell(1, 2).Range.Text, vbCr)(0)
    GigDate = Split(.Cell(1, 3).Range.Text, vbCr)(0)
    GigPost = Split(.Cell(2, 1).Range.Text, vbCr)(0)
    GigLoc = Split(.Cell(2, 2).Range.Text, vbCr)(0)
    GigTime = Split(.Cell(2, 3).Range.Text, vbCr)(0)
    GigFile = Mid(GigDate, 4) & Mid(GigDate, 4, 2) & Left(GigDate, 2) & GigName & " Songs"
  End With
  With DocTgt
    With .PageSetup
      .Orientation = wdOrientPortrait
      .TopMargin = CentimetersToPoints(0.5)
      .BottomMargin = CentimetersToPoints(0.5)
      .LeftMargin = CentimetersToPoints(1)
      .RightMargin = CentimetersToPoints(0.5)
      .Gutter = CentimetersToPoints(0)
      .HeaderDistance = CentimetersToPoints(0.5)
      .FooterDistance = CentimetersToPoints(0.5)
      .PageWidth = CentimetersToPoints(21)
      .PageHeight = CentimetersToPoints(29.7)
      .FirstPageTray = wdPrinterDefaultBin
      .OtherPagesTray = wdPrinterDefaultBin
      .SectionStart = wdSectionNewPage
      .VerticalAlignment = wdAlignVerticalTop
      .BookFoldPrintingSheets = 1
      .GutterPos = wdGutterPosLeft
    End With
    With .Range
      .ParagraphFormat.Alignment = wdAlignParagraphCenter
      .Text = vbCr & vbCr & vbCr & GigNum
      .Paragraphs.Last.Range.Font.Size = 24
      .InsertAfter vbCr & vbCr & GigName & vbCr & vbCr & GigLoc & vbCr & vbCr & GigPost & vbCr & vbCr & GigDate & vbCr & vbCr & GigTime & Chr(12)
      .Paragraphs(7).Range.Font.Size = 36
    End With
  End With
  With .Tables(1)
    For r = 3 To .Rows.Count
      If Len(.Cell(r, 1).Range.Text) = 2 then Exit For
      p = Split(.Cell(r, 1).Range.Text, vbCr)(0) + 6: StrKey = ""
      Set Rng = DocRef.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=p).GoTo(What:=wdGoToBookmark, Name:="\page")
      DocTgt.Range.Characters.Last.FormattedText = Rng.FormattedText
      .Cell(r, 1).Range.Text = r - 2: .Cell(r, 3).Range.Text = Split(Rng.Paragraphs.First.Range.Text, vbCr)(0)
      With Rng
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Font.Color = RGB(255, 0, 0)
          .Execute FindText:="\[[A-G]*\]", MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True, Format:=True, ReplaceWith:=""
        End With
        If .Find.Found = True Then StrKey = .Text
      End With
      .Cell(r, 4).Range.Text = StrKey
    Next
  End With
  With DocTgt
    For Each Fld In .Fields
      If Fld.Type = wdFieldTOCEntry Then
        Fld.Code.Paragraphs(1).Range.Text = vbNullString
      End If
    Next
    .SaveAs2 FileName:="D:\Documents\MJH-20\MJH-Music\LotSU\Gig Sheets\" & GigFile & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .SaveAs2 FileName:="D:\Documents\MJH-20\MJH-Music\LotSU\Gig Sheets\" & GigFile & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
    .Close False
  End With
  .SaveAs2 FileName:="D:\Documents\MJH-20\MJH-Music\LotSU\Gig Sheets\" & GigFile & "Set.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
  .Close False
End With
DocRef.Close False: Set Rng = Nothing: Set DocSrc = Nothing: Set DocRef = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub