Copy Between Two Headings/Texts

[Noob_VBA]

Hello All,

I find this VBA program and have been trying to modify it. I'm having some issues. I'm trying to search multiple word files between two headings. But the headings in each of these word files are not Heading Style format, instead, it is Normal Style. I need the program to search each word documents and output the text/body include tables, photos, etc between the two headings.

Any thoughts on how I can do this?






Sub CP_Between_Text()

Application.ScreenUpdating = False

Dim strFolder As String, strFile As String, strDocNm As String, strTmp As String, strOut As String
Dim wdDoc As Document, Rng As Range, i As Long

Dim FindWord1, FindWord2 As String
Dim result As String
FindWord1 = "System Safety Assessment Summary"
FindWord2 = "Hardware Considerations"

strDocNm = ActiveDocument.FullName
strFolder = GetFolder: If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)

While strFile <> ""
If strFolder & "" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False)
strTmp = ""
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindWord1
.Replacement.Text = ""


.Format = False
.Forward = True
.Wrap = 1
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
For i = 0 To UBound(Split(.Text, ","))
.Text = Split(.Text, ",")(i)
.Execute
If .Found = True Then strTmp = strTmp & ", " & Split(.Text, ",")(i)
Next
End With
If strTmp <> "" Then strOut = strOut & vbCr & strFile & ": " & strTmp
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
ActiveDocument.Range.Text = "The following matches were made:" & strOut
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder( 0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[Noob_VBA]

Hello All,


I'm still can't figure it out.


I try this method but it doesn't printout the results to the word doc.


With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Functional Hazard Analysis/System Safety Assessment Summary^p"
.Style = "Heading 1"
.Format = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If .Find.Found = True Then
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Rng.Start = Rng.Paragraphs.First.Range.End
Rng.End = Rng.Paragraphs.Last.Range.Start
End If

[Guessed]

Your first post says the headings are not using heading styles. Your second post has code that won't work if that is the case.

If you want a hand with this task you need to provide a sample document that demonstrates the actual setup of your files.

You also need to be clearer on what you want to happen when the range is determined. Do you want to output the range on the current printer?

[Noob_VBA]

Hello Andrew,


I'm new to VBA. I find these two Macro programs and have been trying to modify the application. I'm trying to run the Macro to search thru several hundred Word documents for the following headings "System Safety Assessment Summary" and "Hardware Considerations." Once the headings are found, the Macro will copy the body includes tables and figures. The Macro will output the results in the current document running the program, then the Macro will go to the next Word document and repeat the process.


I have attached an example. Any idea how I can do this?


Much appreciated for the assist.

[gmayor]

Your document has lots of manual page breaks. You could convert those to section breaks and then extract the appropriate sections to another document e.g. as follows, which will work with you sample.

Start with no documents open then run the following macro. I would recommend working with a small selection of documents in the selected folder to test the process works for you.

Option Explicit

Sub ExtractData()
'Graham Mayor - https://www.gmayor.com - Last updated - 23 Nov 2021
Dim oDoc As Document
Dim oSource As Document
Dim oRng As Range, oDocRng As Range
Dim lSec As Long, lPara As Long
Dim fDialog As FileDialog
Dim strPath As String, strFile As String

    If Documents.Count = 0 Then Documents.Add

    Set oDoc = ActiveDocument

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With

    strFile = Dir$(strPath & "*.docx")
    While strFile <> ""
        Set oSource = Documents.Open(strPath & strFile)
        Set oRng = oSource.Range
        With oRng.Find
            Do While .Execute("^m")
                oRng.Text = ""
                oRng.InsertBreak wdSectionBreakNextPage
                oRng.Collapse 0
            Loop
        End With

        If Len(oDoc.Range) > 1 Then
            Set oRng = oDoc.Range
            oRng.Collapse 0
            oRng.InsertBreak wdPageBreak
        End If


        For lSec = 1 To oSource.Sections.Count
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*System Safety Assessment Summary*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*Hardware Considerations*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
        Next lSec
        If oDoc.Sections.Count > 2 Then
            Set oRng = oDoc.Sections.Last.Range.Previous
            oRng.End = oDoc.Range.End
            oRng.Delete
        End If

        oSource.Close SaveChanges:=wdDoNotSaveChanges
        strFile = Dir$()
    Wend
lbl_Exit:
    Set fDialog = Nothing
    Set oSource = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oDocRng = Nothing
    Exit Sub
End Sub

[Noob_VBA]

Hello Graham,

Thank you for helping out. I still have over 1000 word documents (.docx) to scan. Adding the section break in each of these documents will take forever. Is there a way to search between "System Safety Assessment Summary" and "Hardware Considerations" without adding the section break? Also, is there a way to output the filename along with the copied information?

[gmayor]

If the documents have manual page breaks like your example, the temporary conversion to section breaks is performed by the macro and takes only a fraction of a second. Where do you want the filename to be placed?

[Noob_VBA]

Hello Graham,


Can I add this code to the existing macro for the section break?

word.Selection.HomeKey

word.Selection.InsertBreak Type:=wdPageSectionBreak

word.Selection.MoveDown

The filename will be output first, then the copied data between the two headings under the filename. Maybe adding a page break before repeating for the next word doc.

Thank you,

New to Marco VBA

[gmayor]

I have added the filename in the code below. What is the purpose of the section break you want adding? It is not required for the process you outlined and there is already a page break between the Word documents. The code works provided the documents are similar to the sample you posted.

Option Explicit

Sub ExtractData()
'Graham Mayor - https://www.gmayor.com - Last updated - 23 Nov 2021
Dim oDoc As Document
Dim oSource As Document
Dim oRng As Range, oDocRng As Range
Dim lSec As Long, lPara As Long
Dim fDialog As FileDialog
Dim strPath As String, strFile As String

    If Documents.Count = 0 Then Documents.Add

    Set oDoc = ActiveDocument

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With

    strFile = Dir$(strPath & "*.docx")
    While strFile <> ""
        Set oSource = Documents.Open(strPath & strFile)
        Set oRng = oSource.Range
        With oRng.Find
            Do While .Execute("^m")
                oRng.Text = ""
                oRng.InsertBreak wdSectionBreakNextPage
                oRng.Collapse 0
            Loop
        End With

        If Len(oDoc.Range) > 1 Then
            Set oRng = oDoc.Range
            oRng.Collapse 0
            oRng.InsertBreak wdPageBreak
        End If

        For lSec = 1 To oSource.Sections.Count
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*System Safety Assessment Summary*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.Text = oSource.Name & vbCr
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*Hardware Considerations*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
        Next lSec
        If oDoc.Sections.Count > 2 Then
            Set oRng = oDoc.Sections.Last.Range.Previous
            oRng.End = oDoc.Range.End
            oRng.Delete
        End If

        oSource.Close SaveChanges:=wdDoNotSaveChanges
        strFile = Dir$()
    Wend
lbl_Exit:
    Set fDialog = Nothing
    Set oSource = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oDocRng = Nothing
    Exit Sub
End Sub

[Noob_VBA]

Hello Graham,

I apologize for the confusion. Not all of the word documents have a page break or section break for the headings. I was looking for a way to search without the page/section break (The only thing consistent is the Heading Titles: "System Safety Assessment Summary" and "Hardware Considerations").

Best Regards,

New To VBA

[gmayor]

That certainly makes things more complicated. Do all the documents have the same order of headings? i.e. is "Hardware Considerations" always followed by "Conclusions" or have I misunderstood the requirement and you only want the "Hardware Considerations" section in the new document? In that case

Option Explicit


Sub ExtractSummary()
'Graham Mayor - https://www.gmayor.com - Last updated - 25 Nov 2021
Const sStart As String = "System Safety Assessment Summary"
Const sEnd As String = "Hardware Considerations"

Dim oDoc As Document
Dim bStartFound As Boolean, bEndFound As Boolean
Dim oSource As Document
Dim oRng As Range, oRng2 As Range, oDocRng As Range
Dim lPara As Long, lStart As Long
Dim fDialog As FileDialog
Dim strPath As String, strFile As String

    If Documents.Count = 0 Then Documents.Add

    Set oDoc = ActiveDocument

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With

    strFile = Dir$(strPath & "*.docx")
    While strFile <> ""
        Set oSource = Documents.Open(strPath & strFile)
        Set oRng = oSource.Range
        For lPara = 1 To oRng.Paragraphs.Count
            If InStr(1, oRng.Paragraphs(lPara).Range.Text, sStart) > 0 Then
                If oRng.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                    oRng.Start = oRng.Paragraphs(lPara).Range.Start
                    lStart = lPara + 1
                    bStartFound = True
                    Exit For
                End If
            End If
        Next lPara

        If bStartFound = False Then GoTo Skip

        For lPara = lStart To oSource.Paragraphs.Count
            Set oRng2 = oSource.Paragraphs(lPara).Range
            If InStr(1, oRng2.Text, sEnd) > 0 Then
                oRng.End = oRng2.Start - 2
                bEndFound = True
            End If
        Next lPara

        If bEndFound = False Then GoTo Skip

        Set oDocRng = oDoc.Range
        If Len(oDocRng) > 1 Then
            oDocRng.Collapse 0
            oDocRng.InsertBreak wdPageBreak
            Set oDocRng = oDoc.Range
            oDocRng.Collapse 0
        End If
        oDocRng.Text = oSource.Name & vbCr
        oDocRng.Paragraphs(1).Range.Font.Size = 14
        oDocRng.Paragraphs(1).Range.Font.Bold = True
        oDocRng.Collapse 0
        oDocRng.FormattedText = oRng.FormattedText
Skip:
        oSource.Close SaveChanges:=wdDoNotSaveChanges
        strFile = Dir$()
    Wend
lbl_Exit:
    Set fDialog = Nothing
    Set oSource = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oDocRng = Nothing
    Exit Sub
End Sub

[Noob_VBA]

This is what I'm looking for. Thank you so much, Graham.

[Noob_VBA]

Hello Graham,

I'm running the macro and notice some documents out of the thousands of word documents, don't have the headings ("System Safety Assessment Summary" and "Hardware Considerations"). In this case, the macro copies the whole document. Is there any way to tell the program to skip or output "No Findings", instead of copying the whole document?

Sincerely,

New To VBA

[gmayor]

Add the line

bStartFound = False: bEndFound = False

immediately after the line

For lPara = 1 To oRng.Paragraphs.Count

[Noob_VBA]

Thank you!