Folks;

After some help from Jezebel and Peter Jamison I have the code below
working.  YEAH!
BUT  (you knew that was coming right!)
It is dog slow.  It takes several minutes to process a one page
document.
I'm looking for ANY angles to improve the code!  So let 'er rip!!!

One thought I have is that Sub ReplaceRoster just blindly keeps
hammering away with 'replace' when the tags have been exhausted.  So
I'd like to tweak it so it stops when there are no more '<' in the
text...
But I'm a little puzzled how best to structure that change.

Thanks Again Jezebel and Peter!!
Steve
_____________________
 Dim storyRange As Word.Range
 Dim tRange as Word.Range
 Dim junk As Long
 Dim shape As Shape
 junk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
 For Each storyRange In ActiveDocument.StoryRanges
   Do
     Select Case storyRange.StoryType
     Case wdPrimaryHeaderStory
     ReplaceRoster storyRange
     On Error Resume Next
       If storyRange.ShapeRange.Count > 0 Then
         For Each shape In storyRange.ShapeRange
                Select Case shape.Type
                    Case msoTextBox
                      If shape.TextFrame.HasText Then
                            Set tRange = shape.TextFrame.TextRange
                            tRange.Find.Execute FindText:=\"<\", Forward:=True
                            If tRange.Find.Found = True Then ReplaceRoster
shape.TextFrame.TextRange
                     End If
                    Case Else
                End Select
         Next
       End If
     Case Else
     End Select
     On Error GoTo 0
     Set storyRange = storyRange.NextStoryRange
   Loop Until storyRange Is Nothing
 Next

Public Sub ReplaceRoster(ByVal myRange As Word.Range)
 ReplaceInRange myRange, \"<SOrg>\", \"Q$SOrg\"
 ReplaceInRange myRange, \"<SFullName>\", \"Q$SFullName\"
[ ...45 more such lines...]
End Sub

Public Sub ReplaceInRange(ByVal myRange As Word.Range, ByVal strSearch
As String , ByVal strReplace As String )
 With myRange.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .Text = strSearch
   .Replacement.Text = strReplace
   .Wrap = wdFindContinue
   .Execute Replace:=wdReplaceAll
 End With
End Sub