1 Attachment(s)
VBA help Only format selected text in manual to schedule level numbering
Attachment 29247Attachment 29247
I would be really grateful for some help with my macro. The macro converts manual numbering to the correct outline schedule level number, converts schedule level 1 to bold and keep with next and any unnumbered paragraphs from body text to body 1 only when text is selected. It all works fine except when it gets to body text to body 1. In my test document I have selected the text to the end of paragraph 2 (so the end of 2.2.2.2) then I run the macro. Paragraph 3 onwards should remain body text but the macro converts the unselected text to body 1. I can't quite work out where I am going wrong. Can anyone help?
Code:
Sub ManualToSchedule_Sched1Bold()
Application.ScreenUpdating = False
Dim Para As Paragraph, Rng As Range, iLvl As Long, i As Paragraph, n As Long, StyleName As String, wrd As Long, Count As Long
If Len(Selection.Range) = 0 Then
MsgBox "Select the text first", vbCritical
Exit Sub
End If
With Selection.Range
For Each i In ActiveDocument.Paragraphs 'Remove all leading spaces e.g tabs, spaces, NBS
For n = 1 To i.Range.Characters.Count
If i.Range.Characters(1).Text = " " Or i.Range.Characters(1).Text = " " Or i.Range.Characters(1).Text = Chr(9) Or i.Range.Characters(1).Text = Chr(160) Then
i.Range.Characters(1).Delete
Else: Exit For
End If
Next n
Next
For Each Para In .Paragraphs
If Para.Range.Information(wdWithInTable) = False Then
Set Rng = Para.Range.Words.First 'Convert manual numbering to Schedule Level numbering
With Rng
If IsNumeric(.Text) Then
While .Characters.Last.Next.Text Like "[0-9. " & vbTab & "]"
.End = .End + 1
Wend
iLvl = UBound(Split(.Text, "."))
If IsNumeric(Split(.Text, ".")(UBound(Split(.Text, ".")))) Then iLvl = iLvl + 1
If iLvl < 10 Then
.Text = vbNullString
Para.Style = "Schedule Level " & iLvl
End If
End If
End With
End If
Next
End With
With Selection.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = "Schedule Level 1" 'format Schedule Level 1 bold with KWN
.Font.Bold = False
.Text = ""
.Replacement.Font.Bold = True
.Replacement.Text = ""
.Replacement.ParagraphFormat.KeepWithNext = True
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
With Selection.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = "Body Text"
.Text = ""
.Replacement.Style = "Body1"
.Replacement.Font.Bold = False
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
