![]() |
|
#1
|
||||
|
||||
![]()
Paul's code looks pretty slick to me and I can't see why it might be failing on your machine. Can you verify that the document is not protected and you are able to add new styles?
I did make some changes to Paul's code to remove the need for the extra arrays. Code:
Sub ApplyCharacterStyles() Application.ScreenUpdating = False Dim Rng As Range, i As Long, j As Long, ArrStyl, ArrItal, ArrBold, ArrUlin, bFnd As Boolean, aSty As Style ArrStyl = Array("Bold", "Italic", "Underline", "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline") With ActiveDocument On Error Resume Next For i = 0 To UBound(ArrStyl) Set aSty = .Styles(ArrStyl(i)) If aSty Is Nothing Then Set aSty = .Styles.Add(Name:=ArrStyl(i), Type:=wdStyleTypeCharacter) End If With aSty.Font .Italic = aSty.NameLocal Like "*Italic*" .Bold = aSty.NameLocal Like "*Bold*" .Underline = aSty.NameLocal Like "*Underline*" End With Set aSty = Nothing Next On Error GoTo 0 For Each Rng In .StoryRanges For i = UBound(ArrStyl) To 0 Step -1 Set aSty = ActiveDocument.Styles(ArrStyl(i)) With Rng.Duplicate With .Find With .Font .Italic = aSty.Font.Italic .Bold = aSty.Font.Bold .Underline = aSty.Font.Underline End With End With Do While .Find.Execute = True If .Style <> aSty Then If .Start <> .Paragraphs.First.Range.Start Or .End <> .Paragraphs.Last.Range.End Then .Style = ArrStyl(i) Else With .Paragraphs.First.Range.Style.Font If .Italic <> aSty.Font.Italic Then If .Bold <> aSty.Font.Bold Then If .Underline <> aSty.Font.Underline Then .Style = aSty End If End If End With End If End If If .Information(wdWithInTable) = True Then If .End = .Cells(1).Range.End - 1 Then .Start = .Cells(1).Range.End If .Information(wdAtEndOfRowMarker) = True Then .Start = .End + 1 End If If .End = Rng.End Then Exit Do .Collapse wdCollapseEnd Loop End With Next Next End With Application.ScreenUpdating = True MsgBox "Finished applying Character Styles" End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
![]() |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Styles: Cannot Apply or Save | Justin | Word | 5 | 11-01-2020 03:20 PM |
Macro to apply Normal dot styles | John9210 | Word VBA | 2 | 06-07-2018 05:15 PM |
Apply styles in word table | 1van | Word VBA | 2 | 11-17-2015 11:05 AM |
search for special character and apply outline? | n00bie-n00b | Word VBA | 0 | 10-12-2014 03:17 AM |
automatically extract footnotes into new file and apply character format to footnote | hrdwa | Word | 0 | 02-27-2010 03:16 AM |