Finding,Sorting and creating a new Section VBA Script help

tonykekw · #1 01-21-2024, 09:21 PM

Hello again, I have a new question, and I haven't found something similar to my problem at hand yet.

What I would like to do is find a value (for e.g., [red]) within my document. Just how the built-in Navigation pane does. This is because I have many "tags" at the end of sentences and/or paragraphs that end with such "tags".

Then I would like to essentially grab the entire sentence/paragraph that comes before the "tags" along with the tag itself.

For example, Adam ate an apple.[Red]

I look up the "tag" [Red], and I pull that entire sentence before it along with the tag.

If possible, I would also like to have the heading level name with it. The document uses many of the MS Word built-in heading levels to organize the document.

I have managed to write some scripts that try to do what I want, but they time out or I have an error.

The reason I would like to do this is so that the reader can only read what they want to read. Such as if they only want to read the tag [blue] or #triangle. They can just click on a section of the document that says "[blue] documentation.

I know this is confusing and very long and specific, but I have been working on trying to figure this one out myself for about a month before asking for help. I would provide my code snippets, but they don't work, and I did use ChatGPT to help me with them. Save myself the embarrassment.

Italophile · #2 01-22-2024, 03:53 AM

How do you propose to identify whether you need the previous sentence, or the paragraph?

tonykekw · #3 01-22-2024, 08:59 AM

youre right, we don't know. Thats something I will have to go in and re-structure the document for. Disregarding the sentence or paragraph. Only the section headers would work for now.

I wrote a script but it just copy pasted the entire docuemnt twice. Or I recive a runtime error.

Code:

Sub OrganizeSections()
    Dim doc As Document
    Dim sec As Section
    Dim newSection As Section
    
    ' Set the source document
    Set doc = ActiveDocument
    
    ' Disable screen updating to improve performance
    Application.ScreenUpdating = False
    
    ' Loop through each section in the source document
    For Each sec In doc.Sections
        ' Check if the section contains "[A]"
        If InStr(sec.Range.Text, "[A]") > 0 Then
            ' Create a new section after the current one
            Set newSection = doc.Sections.Add
            ' Copy the content of the section to the new section
            newSection.Range.FormattedText = sec.Range.FormattedText
            ' Add a new line after the copied section
            newSection.Range.InsertAfter vbNewLine
        End If
    Next sec
    
    ' Enable screen updating
    Application.ScreenUpdating = True
End Sub

Italophile · #4 01-22-2024, 09:20 AM

How are you defining the term "section"?

tonykekw · #5 01-22-2024, 09:29 AM

I am defining the "section" as the heading level. I use MS Words built in heading levels.

for example :
heading level1
- heading level 2
- heading level 3

In the application it's called heading 1, heading 2, ... etc.

Italophile · #6 01-22-2024, 09:45 AM

I thought that might be the case.

In Word, the term "section" has an extremely specific meaning. A new blank document consists of one section. As section breaks are added the number of sections increases.

What you are referring to as a "section" is, as you identify in your post, a "heading level". Word has a number of predefined bookmarks (see Predefined Bookmarks | Microsoft Learn), one of which will give you the heading level. For an example of usage see https://www.msofficeforums.com/word-...selection.html

Guessed · #7 01-22-2024, 03:31 PM

Try this macro. It harvests any text in the paragraph which is in front of the trigger word - in this case "[Red]" and includes a reference to the nearest preceding Heading.

Code:

Sub GatherRound()
  Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  Set aDocNew = Documents.Add
  Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 2)
  aTbl.Cell(1, 1).Range.Text = "Heading"
  aTbl.Cell(1, 2).Range.Text = "Text"
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[Red]"
    .Forward = True
    Do While .Execute
      aRng.Start = aRng.Paragraphs(1).Range.Start
      Set aRow = aTbl.Rows.Add
      aRow.Cells(2).Range.FormattedText = aRng.FormattedText
      Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
      aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
      aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
      aRng.Collapse Direction:=wdCollapseEnd
      aRng.End = aDoc.Range.End
    Loop
  End With
End Sub

tonykekw · #8 01-22-2024, 11:20 PM

This worked very beautifully. This will help a lot. I can work with this can mess around with it to fit some other needs. Many thanks!

tonykekw · #9 01-24-2024, 06:18 PM

Hey I was playing around with the script you gave me and I was wondering if it can also harvest data in front of the search value. If the data in front of the value is a bullet list/number list and or multilevel list?

Code:

Sub GatherRound()
  Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  Set aDocNew = Documents.Add
  Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 2)
  aTbl.Cell(1, 1).Range.Text = "Heading"
  aTbl.Cell(1, 2).Range.Text = "Text"
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[Red]"
    .Forward = True
    Do While .Execute
      aRng.Start = aRng.Paragraphs(1).Range.Start
      Set aRow = aTbl.Rows.Add
      aRow.Cells(2).Range.FormattedText = aRng.FormattedText
      Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
      aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
      aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
      aRng.Collapse Direction:=wdCollapseEnd
      aRng.End = aDoc.Range.End
    Loop
  End With
End Sub

I was adding this:

Code:

' Check if the paragraph is part of a list
            If aRng.Paragraphs(1).Range.ListFormat.ListType <> wdListNoNumbering Then
                Set aListFormat = aRng.Paragraphs(1).Range.ListFormat
                aRow.Cells(1).Range.Text = aRow.Cells(1).Range.Text & " " & GetListText(aListFormat)

Guessed · #10 01-24-2024, 07:47 PM

Maybe something like this

Code:

Sub GatherRound()
  Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
  Dim sNum As String
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  Set aDocNew = Documents.Add
  Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 2)
  aTbl.Cell(1, 1).Range.Text = "Heading"
  aTbl.Cell(1, 2).Range.Text = "Text"
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[Red]"
    .Forward = True
    Do While .Execute
      aRng.Start = aRng.Paragraphs(1).Range.Start
      Set aRow = aTbl.Rows.Add
      If aRng.ListFormat.ListType = wdListNoNumbering Then
        aRow.Cells(2).Range.FormattedText = aRng.FormattedText
      Else
        sNum = aRng.ListFormat.ListString
        aRow.Cells(2).Range.Text = sNum & vbTab & aRng.Text
      End If
      Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
      aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
      aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
      aRng.Collapse Direction:=wdCollapseEnd
      aRng.End = aDoc.Range.End
    Loop
  End With
End Sub

tonykekw · #11 01-25-2024, 09:13 AM

Hey, the script works well in terms of pulling the data before it. I am not sure if its beacuse the document is so large it starts to not respond and I have to hard restart Word. This only happens if the when the script has to find many cases of the value. it does about 80% of the document then it repeats the same data for pages on end. As for pulling lists in front of our search value. Not getting any data. It could be that immeditly after our search value there isnt a list but another one of the "tags" I use.

Example: [Red] [Blue] and/or [Red] #ABC

apple
orange

that may be an issue not to sure. Again help on this has been more than enough so many thanks for input.

tonykekw · #12 01-29-2024, 08:27 AM

Code:

Sub GatherRoundUpdated()
    Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
    Dim sNum As String, lastPosition As Long
    
    Set aDoc = ActiveDocument
    Set aDocNew = Documents.Add
    Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 2)
    aTbl.Cell(1, 1).Range.Text = "Heading"
    aTbl.Cell(1, 2).Range.Text = "Text"
    
    Set aRng = aDoc.Range
    aRng.Find.ClearFormatting
    aRng.Find.Replacement.ClearFormatting
    aRng.Find.Text = "[Red]"
    aRng.Find.Forward = True
    
    Do While aRng.Find.Execute
        If aRng.Start = lastPosition Then Exit Do ' Exit loop if stuck at the same position
        
        lastPosition = aRng.Start
        
        Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
        If Not aRngHead Is Nothing Then
            aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
            Set aRow = aTbl.Rows.Add
            
            If aRng.ListFormat.ListType = wdListNoNumbering Then
                aRow.Cells(2).Range.FormattedText = aRng.FormattedText
            Else
                sNum = aRng.ListFormat.ListString
                aRow.Cells(2).Range.Text = sNum & vbTab & aRng.Text
            End If
            
            aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
        End If
        
        aRng.Collapse Direction:=wdCollapseEnd
        aRng.End = aDoc.Range.End
    Loop
    
    ' Clean up
    Set aRng = Nothing
    Set aDoc = Nothing
    Set aDocNew = Nothing
    Set aTbl = Nothing
    Set aRow = Nothing
End Sub

This was my attempt

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Help with creating a script with VBA	lenziwag93	Excel Programming	1	04-20-2022 12:57 AM
Need Help to Script to align all the tables only as of a section to end of doc?	Cendrinne	Word VBA	4	04-05-2021 11:37 AM
Creating a master spreadsheet for sorting information	Notsonerdy	Excel Programming	8	05-31-2016 04:39 AM
Creating a list and sorting alphabetically.	irvsax	Word	4	09-04-2013 11:47 PM
Creating a sorting method.	Balliol	Word	2	07-25-2013 06:18 AM