Sub CopyWordstoStyleSheet()
'2021-06-16
'
'Original source macro by Hilary Powers 1/30/04; updated 4/6/04
'Adapted by Jack M. Lyon for use with editorial style sheet
'Adapted by Michael Schuler 6/4/2015 to expand functions and later revised
'
'This macro copies a selection in one Word document (e.g., a manuscript) to another document (e.g., a style sheet)
'It operates if two and only two Word documents are open
'If it finds a heading consisting of "Word List" (the value of the variable "sSectionTitle") it places the selection directly after the heading paragraph
'if it finds no matching heading, it places the selection at the end of the document
'All formatting of the selection is removed except italics
'The macro inserts brackets after the pasted content and places the cursor between them, to simplify adding a desctiption
'Running the macro a second time (with nothing selected) return focus back to the source document

Dim bItal As Boolean
Dim bSmartStatus As Boolean
Const sSectionTitle As String = "Word List"

If Application.Windows.Count <> 2 Then
    MsgBox ("This macro only works if two Word documents (the source document and the stylesheet) are open.")
    GoTo final
End If

If Selection.Type = wdSelectionIP Then  'No selection
    GoTo hedback
Else
    While (Asc(Selection.Characters.Last) = 13) Or (Asc(Selection.Characters.Last) = 32) Or (Asc(Selection.Characters.Last) = 9) Or (Asc(Selection.Characters.Last) = 160)
        Selection.MoveEnd Unit:=wdCharacter, Count:=-1
        If Selection.Type = wdSelectionIP Then GoTo final
    Wend
    If Selection.Font.Italic = True Then bItal = True
    Selection.Copy
    WordBasic.NextWindow
    WordBasic.StartOfDocument
    With Selection.Find
        .ClearFormatting
        .Text = sSectionTitle & "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    If Selection.Find.Execute Then
        Selection.MoveRight
        bHeadingFound = True
    Else
        Selection.EndKey Unit:=wdStory
    End If
    bSmartStatus = Options.SmartCutPaste
    Options.SmartCutPaste = False
    Selection.Paste
    Selection.TypeText Text:=" []"
    Selection.TypeParagraph
    Selection.MoveLeft Count:=2
    Selection.Expand Unit:=wdParagraph

    With Selection
        .ClearFormatting
        .Range.HighlightColorIndex = wdNoHighlight 'removes any highlighting
    End With
    
    Selection.MoveEnd Unit:=wdCharacter, Count:=-4
    Selection.Font.Italic = bItal 'makes insertion italic if the entire source is italic
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.MoveRight Count:=2
    Options.SmartCutPaste = bSmartStatus
    GoTo final
End If

hedback:
WordBasic.NextWindow

final:

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchCase = False
        .Text = ""
    End With

End Sub