Sub WeeklySuspense()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, bDI As Boolean, bZJ As Boolean
bDI = False: bZJ = False
'Loop thru all open docs to find our two
For i = 1 To Documents.Count
Select Case Split(Documents(i).Name, "doc")(0)
'Prepare ID-SUSP-DI
Case "ID-SUSP-DI"
bDI = True: j = i
With Documents(i).Range
With .Find
.ClearFormatting
.Text = "AGED SUSPENSE RANGE TOTALS"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If .Find.Found Then
.Start = .Paragraphs.First.Start
.End = Documents(i).Range.End
.Text = Chr(12)
Documents(i).Range.Font.Color = wdColorBlue
End If
End With
'Prepare ID-SUSP-ZJ
Case "ID-SUSP-ZJ"
bZJ = True: k = i
With Documents(i).Range
With .Find
.ClearFormatting
.Text = "AGED SUSPENSE RANGE TOTALS"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If .Find.Found Then
.Start = .Paragraphs.First.Start
.End = Documents(i).Range.End
.Text = vbNullString
Documents(i).Range.Font.Color = wdColorRed
End If
End With
Case Else
End Select
'If both found, combine ID-SUSP-DI & ID-SUSP-ZJ
If (bDI = True) And (bZJ = True) Then
With Documents(j).Range
.Characters.Last.FormattedText = Documents(k).Range.FormattedText
'Close the ZJ document
Documents(k).Close SaveChanges:=False
'Reformat the DI document
With .Find
.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Replacement.Text = ""
.Text = "0[=]{108}"
.Execute Replace:=wdReplaceAll
.Text = "[=]{108}"
.Execute Replace:=wdReplaceAll
.Text = " DI80440B[ ]@AGED SUSPENSE REPORT[ ]@PAGE: [0-9]{3}"
.Execute Replace:=wdReplaceAll
.Text = "^13[ ]@[0-9]{2}/[0-9]{2}/20[0-9]{2}"
.Execute Replace:=wdReplaceAll
.Text = "[ ]@CUSTOMAX (DIRECT)"
.Execute Replace:=wdReplaceAll
.Text = "[ ]@CUSTOMAX (JV)"
.Execute Replace:=wdReplaceAll
.Text = "[ ]@FUNCTION:[ ]{1,}"
.Replacement.Text = " FUNCTION:^t"
.Execute Replace:=wdReplaceAll
.Text = "[ ]@FUNCTION:"
.Execute Replace:=wdReplaceAll
.Text = "-SERV OFFICE[ ]@0-29[ ]@30-60[ ]@61-90[ ]@91-120[ ]@121-150[ ]@151-180[ ]@180+[ ]@TOTAL"
.Replacement.Text = "-SO^t0-29^t30-60^t61-90^t91-120^t121-150^t151-180^t180+^tTOTAL"
.Execute Replace:=wdReplaceAll
.Text = "[ ]{2,}"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
.Text = "^t[=]{2,}"
.Execute Replace:=wdReplaceAll
.Text = "[=]{1,}"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
.Text = "^t^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "[^t]{2,}"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
.Text = "^13[0-1]^13"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With
.ParagraphFormat.TabStops.ClearAll
.DefaultTabStop = InchesToPoints(1.1)
With .PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.3)
.FooterDistance = InchesToPoints(0.3)
.PageWidth = InchesToPoints(14)
.PageHeight = InchesToPoints(8.5)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
End With
'Save the DI document as a new file.
.SaveAs FileName:="C:\_MIS FILES\ID-SUSP-DIZJ COMBINED.docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, _
ReadOnlyRecommended:=False, AddToRecentFiles:=True, _
EmbedTrueTypeFonts:=False, SaveAsAOCELetter:=False, _
WritePassword:="", Password:=""
'Close the DI document.
'.Close SaveChanges:=False
End With
Exit For
End If
Next
If (bDI = False) And (bZJ = False) Then
MsgBox "ID-SUSP-DI and ID-SUSP-ZJ not found", vbExclamation
ElseIf bDI = False Then
Documents("ID-SUSP-ZJ").Close SaveChanges:=False
MsgBox "ID-SUSP-DI not found", vbExclamation
ElseIf bZJ = False Then
Documents("ID-SUSP-DI").Close SaveChanges:=False
MsgBox "ID-SUSP-ZJ not found", vbExclamation
End If
Application.ScreenUpdating = True
End Sub
