#1
|
|||
|
|||
Finding,Sorting and creating a new Section VBA Script help
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. |
#2
|
|||
|
|||
How do you propose to identify whether you need the previous sentence, or the paragraph?
|
#3
|
|||
|
|||
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 |
#4
|
|||
|
|||
How are you defining the term "section"?
|
#5
|
|||
|
|||
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. |
#6
|
|||
|
|||
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 |
#7
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#8
|
|||
|
|||
Thank you
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!
|
#9
|
|||
|
|||
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 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) |
#10
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#11
|
|||
|
|||
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
that may be an issue not to sure. Again help on this has been more than enough so many thanks for input. |
#12
|
|||
|
|||
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 |
|
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 |