Making a list with VBA.

[ol7ca]

Hi experts,

I have a Word document with a simple text in it (it might be any). Some words and sentences are formatted in bold. I need to find everything formatted in bold, copy and create a list below the text.
I have done a script which is finding everything formatted in bold but I can’t make a list below the text. I will appreciate for help.
Thanks.

My script below:

Sub SubtractBoldTxt()

Dim s As Range
Dim doc As Document
Dim sHeader$
Dim iLen%

Set doc = Word.Documents("Doc2.docm")


For Each s In doc.Words
If s.Words(1).Bold = True Then
x = s.Words(1).Bold
s.Font.ColorIndex = wdRed
s.Select

End If
Next

End Sub

[macropod]

You could use something like:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.Bold = False
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.Execute Replace:=wdReplaceAll
.Format = False
.Text = "[^13]{1,}"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
.Copy
ActiveDocument.Undo 2
.InsertAfter Chr(12)
.Characters.Last.Paste
.Characters.Last.Delete
End With
Application.ScreenUpdating = True
End Sub
The above code adds the bold terms to a new last page in the document.

[ol7ca]

It is working great! Paul, thanks a lot!:beerchug:

could you, please, add a numbering format to this new list?

thanks.

[gmaxey]

While Paul's code will be undoubtably faster in long documents with many bold words, and he will probably be back to school us both, I can only offer the following:

Sub ScratchMacro()
Dim oRng As Word.Range
Dim oRngList As Word.Range
Dim oFld As Word.Field
Set oRngList = ActiveDocument.Range
With oRngList
.Collapse wdCollapseEnd
.InsertBefore Chr(12)
.Characters.First.Font.Bold = False
End With
Set oRng = ActiveDocument.Range
With oRng.Find
.Font.Bold = True
While .Execute
With oRngList
.Collapse wdCollapseEnd
Set oFld = .Fields.Add(oRngList, wdFieldSequence, "SeqA", False)
.MoveEnd wdCharacter, Len(oFld.Code.Text) + 2
.InsertAfter ". " & oRng & vbCr
End With
Wend
End With
End Sub

[ol7ca]

Many thanks, Greg! This is exactly what I need!

I appreciate your help, guys!

[macropod]

My approach would be along the lines of:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.Bold = False
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.Execute Replace:=wdReplaceAll
.Format = False
.Text = "[^13]{1,}"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
.Copy
ActiveDocument.Undo 2
.InsertAfter Chr(12)
Set Rng = .Characters.Last
With Rng
.Paste
.Start = .Start + 1
.ListFormat.ApplyNumberDefault
.Characters.Last.Delete
End With
End With
Application.ScreenUpdating = True
End Sub

[gmaxey]

Paul, That is because your approaches approach magic ;-)