#1
|
|||
|
|||
Create document index looking for certain formatted text
For PowerPoint, you folks created a macro for me that goes through every text box on every slide, grabs the text that's red and bolded and the slide it's on, and then makes an alphabetized index with that. I use it for college notes and it's worked great. Now, for formatting and other reasons, I've transitioned all the data from 300+ slides to Word. But, if possible, I'd still like to be able to use that type of index. Can anyone assist in modifying this macro to work with Word (look for red bolded text and what pages it's on and create an index) )The index can be created in a separate Word document so it doesn't interfere with the page numbers of the subject document.)? Regards, leaning Code:
Sub StartHere() Dim osld As Slide Dim oshp As Shape Dim rayTitles() As String Dim i As Integer ReDim rayTitles(1 To 1) For Each osld In ActivePresentation.Slides For Each oshp In osld.Shapes If oshp.HasTextFrame Then If oshp.TextFrame.HasText Then For i = 1 To oshp.TextFrame.TextRange.Runs.Count With oshp.TextFrame.TextRange.Runs(i).Font If .Color.RGB = vbRed And .Bold = True Then rayTitles(UBound(rayTitles)) = oshp.TextFrame.TextRange.Runs(i) & "\" & osld.SlideNumber ReDim Preserve rayTitles(1 To UBound(rayTitles) + 1) End If End With Next i End If End If Next oshp Next osld ReDim Preserve rayTitles(1 To UBound(rayTitles) - 1) Call mySort(rayTitles) Call make_sum(rayTitles) End Sub Function mySort(ArrayIn As Variant) As Variant Dim b_Cont As Boolean Dim lngCount As Long Dim strSwap As String Do b_Cont = False For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1 'If ArrayIn(lngCount) > ArrayIn(lngCount + 1) Then If LCase(ArrayIn(lngCount)) > LCase(ArrayIn(lngCount + 1)) Then strSwap = ArrayIn(lngCount) ArrayIn(lngCount) = ArrayIn(lngCount + 1) ArrayIn(lngCount + 1) = strSwap b_Cont = True End If Next lngCount Loop Until Not b_Cont End Function Sub make_sum(rayInstring As Variant) Dim osld As Slide Dim i As Integer For Each osld In ActivePresentation.Slides If osld.Tags("SUM") = "YES" Then osld.Delete Exit For End If Next osld Set osld = ActivePresentation.Slides.Add(1, ppLayoutText) osld.Tags.Add "SUM", "YES" osld.Shapes(2).TextFrame2.AutoSize = msoAutoSizeTextToFitShape osld.Shapes(2).TextFrame.Ruler.TabStops.Add ppTabStopLeft, 450 With osld For i = 1 To UBound(rayInstring) .Shapes(2).TextFrame.TextRange = .Shapes(2).TextFrame.TextRange & Split(rayInstring(i), "\")(0) & " (" & Split(rayInstring(i), "\")(1) & ")" & vbCrLf & vbCrLf Next i End With MsgBox "Done", vbInformation, "Done!" End Sub |
#2
|
|||
|
|||
All,
I found this! I have a lot of red-boldeds, so it gives the "not responding" message while it is running, so I'd like to add a status indicator, but otherwise, it builds the list, then you click in wherever in your document you want the index to start, References> Insert Index, and POW! Instant Index. I'll have to change the font to smaller and to save paper and flipping through pages, make it so it's 3-4 columns instead of 2, but as it is, it works great! So, unless anyone has anything to improve on this, I'm good. Thanks, Allen Wyatt! https://wordribbon.tips.net/T010438_..._an_Index.html Code:
Sub InsertingIndexEntries() Application.ScreenUpdating = False 'Go to the first page of the document Selection.HomeKey wdStory, wdMove 'Set up the Find and Replace operation Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchWildcards = False .Font.Bold = True .Font.ColorIndex = wdRed ' I added this so it looks for red text End With 'Finds the bold text and inserts an index entry. Do Selection.Find.Execute If Selection.Find.Found Then 'Checks if the Index field was selected 'This occurs if it does not contain any entries If UCase(Selection.Range.Text) <> "NO INDEX ENTRIES FOUND." Then 'Insert an index entry and use the text within 'the selected range as the entry name ActiveDocument.Indexes.MarkEntry _ Range:=Selection.Range, _ Entry:=Selection.Range.Text, _ EntryAutoText:=Selection.Range.Text, _ CrossReference:="", _ CrossReferenceAutoText:="", _ BookmarkName:="", _ Bold:=False, _ Italic:=False, _ Reading:="" 'Move past text that was found and the new index entry Selection.MoveRight wdCharacter, 1, wdExtend Selection.Collapse wdCollapseEnd End If End If Loop While Selection.Find.Found Application.ScreenUpdating = True Application.ScreenRefresh MsgBox "Done" End Sub |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How do I create an index of every word in a document? | jbengal | Word | 5 | 11-23-2022 02:17 PM |
Pasted text is not formatted correctly in protected document | Lena | Word | 3 | 04-19-2017 05:32 AM |
Macro to keep formatted form fields after mail merge or replace text with formatted form fields | jer85 | Word VBA | 2 | 04-05-2015 10:00 PM |
Underlined Purple Text and "formatted" boxes at side of document | SeanCGR | Word | 1 | 06-20-2014 06:49 AM |
How to create an Index for an existing document | JimAlexander | Word | 0 | 11-10-2013 11:19 AM |