Need macro to split large word doc by headings - Page 2

Attribute VB_Name = "SPLIT_BY_HEADINGS" Option Explicit Const levels = 2 ''Levels to consider in parsing Dim level() As Integer ''Level counter- reset lower levels at each turn of a higher level Sub SplitByPara() Dim I As Integer ''counter variable Dim Para As Paragraph ''loop para Dim ParaLast As Paragraph ''last paragraph the caught flac Dim paraPriev As Paragraph ''paragraph from previous loop Dim aDoc As Document ''active document Dim FP As String ''File Path Set aDoc = ActiveDocument ''abbreviated active document FP = aDoc.Path & "\" & StrFormat(aDoc.Name) NewFolder FP ''Call to new folder- open folder or bring focus to front ReDim level(1 To levels) Set ParaLast = aDoc.Paragraphs.First ''prime paragraphs for loop Set paraPriev = aDoc.Paragraphs.First ''prime paragraphs for loop '''Iterate through paragraphs in current document''' For I = 2 To aDoc.Paragraphs.Count ''paras from next-to-last to first Set Para = aDoc.Paragraphs(I) 'If aDoc.Paragraphs.Count = 1 Or _ ' (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _ ' And Para.Range.Text > "") _ ' Then If (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _ And Para.Range.Text > "") _ Then '''copy form para2 to para ParasWriteOut FP, I, ParaLast, paraPriev Set ParaLast = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set ref to last flag point End If Set paraPriev = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set previous paragraph Next I ParasWriteOut FP, I, ParaLast, paraPriev '''''''''''''''''''''''''''''''''''''''''''''writeout last para End Sub Sub ParasWriteOut(FP As String, I As Integer, Parastart As Paragraph, ParaEnd As Paragraph) Dim fn As String ''File name Dim bDoc As Document ''writeout document per piece Dim rng As Range ''Range to write out Dim x Dim J As Integer fn = format(I, "0000") & "-" If Not Parastart.Range.ListFormat.List Is Nothing Then ''use numbers from list to write out x = Split(PadParanums(Parastart.Range.ListFormat.ListString, 2), "-") For J = 1 To levels level(J) = Val(x(J - 1)) Next J ElseIf Parastart.OutlineLevel <= levels Then ''use level formatting level(Parastart.OutlineLevel) = level(Parastart.OutlineLevel) + 1 ''increment levels ''fn = fn & PadParanums(Parastart.OutlineLevel, levels) & "-" End If For J = Parastart.OutlineLevel + 1 To levels level(J) = 0 ''reset levels Next J fn = fn & PadParanums(level(1) & "-" & level(2), levels) & "-" fn = Left(Trim(fn & Parastart.Range.Text), 64) fn = StrFormat(fn) Set rng = ActiveDocument.Range(Parastart.Range.Start, ParaEnd.Range.End) Set bDoc = Documents.Add(Visible:=False) bDoc.Content.FormattedText = rng '''reset colors to automatic bDoc.Content.Font.Color = wdColorAutomatic On Error Resume Next VBA.Kill FP & fn bDoc.SaveAs FP & fn, fileformat:=Word.wdFormatDocument, addtorecentfiles:=False, allowsubstitutions:=False ''allow substitutions allows word to substitutie characters with similar looking characters (ie © with (C)) On Error GoTo 0 bDoc.Close False Set bDoc = Nothing End Sub Private Function PadParanums(strString As String, Optional levels As Integer) As String '' add 0's in numbered formats Dim x Dim I, xI strString = StrFormat(strString) x = Split(strString, "-") Const format = "000" xI = -1 On Error Resume Next xI = UBound(x) On Error GoTo 0 For I = 0 To xI If x(I) Like "*#*" Then PadParanums = PadParanums & Right(format & x(I), 3) & "-" End If Next I For I = UBound(Split(PadParanums, "-")) To levels - 1 ''use padparanums to determine number of levels defined then add padded 000- for remining PadParanums = PadParanums & format & "-" Next I PadParanums = StrFormat(PadParanums) End Function Private Function Parastyles(Para As Paragraph, strStyles) As Boolean Dim I As Integer Dim K As Integer I = -1 On Error Resume Next I = UBound(strStyles) On Error GoTo 0 For K = 0 To I If Para.Style Like strStyles(K) Then Parastyles = True Exit Function End If Next K End Function Function StrFormat(strString As String) As String Dim regex As New regexp With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "[^a-zA-Z0-9\-]" End With StrFormat = regex.Replace(strString, "-") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "\-{1,}" End With StrFormat = regex.Replace(StrFormat, "-") '''Remove trailing dashes With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "\-{1,}(?=\s|$)" End With StrFormat = regex.Replace(StrFormat, "") End Function Sub NewFolder(FP As String, Optional DoNotOpen As Boolean) Dim OpenFold As Variant Dim oShell As Object Dim Wnd As Object ''Dim strFolder ''OpenFold = "mysubfolder" ''strFolder = "U:\myfolder\" & OpenFold Set oShell = CreateObject("Shell.Application") ''Wnd.LocationName ''Cread subfolder for paragraphs On Error Resume Next VBA.MkDir (FP) FP = FP & "\" On Error GoTo 0 For Each Wnd In oShell.Windows Debug.Print Wnd.Document.Folder.Self.Path '' If Wnd.LocationName = "Windows Explorer" Then If LCase(Wnd.Document.Folder.Self.Path & "\") = LCase(FP) Then Wnd.Visible = True Exit Sub End If ''End If Next Wnd If Not DoNotOpen Then Shell "C:\WINDOWS\explorer.exe """ & FP & "", vbNormalFocus End Sub