Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-16-2021, 10:18 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default Copy Between Two Headings/Texts

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
Reply With Quote
  #2  
Old 11-20-2021, 12:08 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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
Reply With Quote
  #3  
Old 11-20-2021, 04:31 AM
Guessed's Avatar
Guessed Guessed is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 2,752
Guessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud ofGuessed has much to be proud of
Default

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?
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #4  
Old 11-22-2021, 09:27 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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.
Attached Files
File Type: docx Example Number 1.docx (251.9 KB, 4 views)
Reply With Quote
  #5  
Old 11-23-2021, 05:35 AM
gmayor's Avatar
gmayor gmayor is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2019
Expert
 
Join Date: Aug 2014
Posts: 3,632
gmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to behold
Default

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.

Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #6  
Old 11-23-2021, 12:14 PM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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?
Reply With Quote
  #7  
Old 11-23-2021, 10:22 PM
gmayor's Avatar
gmayor gmayor is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2019
Expert
 
Join Date: Aug 2014
Posts: 3,632
gmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to behold
Default

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?
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #8  
Old 11-24-2021, 03:38 PM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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
Reply With Quote
  #9  
Old 11-24-2021, 10:18 PM
gmayor's Avatar
gmayor gmayor is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2019
Expert
 
Join Date: Aug 2014
Posts: 3,632
gmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to behold
Default

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.

Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #10  
Old 11-25-2021, 01:01 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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
Reply With Quote
  #11  
Old 11-25-2021, 02:49 AM
gmayor's Avatar
gmayor gmayor is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2019
Expert
 
Join Date: Aug 2014
Posts: 3,632
gmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to behold
Default

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
Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #12  
Old 11-27-2021, 10:42 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

This is what I'm looking for. Thank you so much, Graham.
Reply With Quote
  #13  
Old 11-30-2021, 09:20 AM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

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
Reply With Quote
  #14  
Old 12-01-2021, 12:32 AM
gmayor's Avatar
gmayor gmayor is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2019
Expert
 
Join Date: Aug 2014
Posts: 3,632
gmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to beholdgmayor is a splendid one to behold
Default

Add the line
Code:
bStartFound = False: bEndFound = False
immediately after the line
Code:
For lPara = 1 To oRng.Paragraphs.Count
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #15  
Old 12-01-2021, 12:28 PM
Noob_VBA Noob_VBA is offline Copy Between Two Headings/Texts Windows 10 Copy Between Two Headings/Texts Office 2016
Novice
Copy Between Two Headings/Texts
 
Join Date: Nov 2021
Posts: 9
Noob_VBA is on a distinguished road
Default

Thank you!
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Need to copy texts from excel and paste in to the Notepad++ in between the particular tags ganesang Word VBA 2 08-27-2018 02:05 AM
Copy Between Two Headings/Texts Applied Styles to Headings in Multi-Level List; now ALL second level headings are 1.XX NNL Word 1 08-09-2017 02:52 PM
Numbered headings not working as expected after customising headings seanspotatobusiness Word 5 03-03-2017 04:44 AM
Copy, Paste, and Format Multiple Headings Dretherix Word VBA 2 02-12-2016 08:26 AM
Trying to find and copy all headings at the same time WaltR Word 7 08-21-2012 03:12 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:03 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2021, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2021 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft