Cannot insert text into merged table cells

[Byron G]

Hi there,

I'm using Word 2007. When publishing our manuals to Word we have numerous
macros that run after publishing to insert headers, footers, format tables,
and format certain text etc.

We have a macro that inserts the text "Note: " , "Tip: " or "Caution: " in
front of the relevant text when it encounters text of a specific style.

We have upgraded our publishing software, and I find that the macro will no
longer insert the text into cells that have been merged into another cell.

I'm now receiving the following run-time error '5960'
"cannot Insert text into a cell which has been merged into another cell.

Could you please provide me with some tips or ideas on how to fix this?

Regards,

 

[Byron G]

Apologies, here is the code...

-----------------------------------------------------------------------------------------------
Option Explicit

Sub FormatNotes()
Call FormatNotesTipsCautions("Note", "Note", "Note: ")
Call FormatNotesTipsCautions("Note", "List Note", "Note: ")
Call FormatNotesTipsCautions("Note", "List Note 2", "Note: ")
Call FormatNotesTipsCautions("Note", "Table Note", "Note: ")
Call FormatNotesTipsCautions("Note", "Table List Note", "Note: ")

Call FormatNotesTipsCautions("Tip", "Tip", "Tip: ")
Call FormatNotesTipsCautions("Tip", "List Tip", "Tip: ")
Call FormatNotesTipsCautions("Tip", "List Tip 2", "Tip: ")
Call FormatNotesTipsCautions("Tip", "Table Tip", "Tip: ")

Call FormatNotesTipsCautions("Caution", "Caution", "Caution: ")
Call FormatNotesTipsCautions("Caution", "List Caution", "Caution: ")
Call FormatNotesTipsCautions("Caution", "List Caution 2", "Caution: ")
Call FormatNotesTipsCautions("Caution", "Table Caution", "Caution: ")


End Sub

Private Sub FormatNotesTipsCautions(NoteType As String, FindStyle As String,
InsertText As String)

Dim SelStart As Long
Dim SelEnd As Long


Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(FindStyle)

With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

While Selection.Find.Found
SelStart = Selection.Start
SelEnd = Selection.End

Selection.MoveLeft Unit:=wdCharacter, Count:=2

If InStr(1, Selection.Style, NoteType) <= 0 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.InsertBefore (InsertText)
Selection.Font.Reset
Selection.Font.Bold = True
End If

Selection.Start = SelEnd
Selection.End = Selection.Paragraphs(1).Range.End

Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Find.Execute
Wend
End Sub
-----------------------------------------------------------------------------------------