Evolved Macro is Failing Intermitently - need help to modernize please

[mstuf]

I have a Macro that has evolved thru the last 12 years - It started in office 2000 and was founded with Generous help from others here combined with experimentation and Luck. Its been edited - revised - expanded all with my knowledge of HTML ending at 4. It was edited to work in Office 2007. I now have Office 2016 and a more powerful computer than ever but the macro has been failing lately.
I wonder if someone would help and look at the code for ways to make it function more efficiently.
I know its a Spagetti Macro with many program to program commands that I'm sure there are better ways to accomplish.
This Macro Cuts a chosen Row from one Excel File and Pastes it into another. It then copies designated Cells from the Pasted Row and places them in a Word Document in a specified position and order.
Sometimes it runs just fine - I use it about 150 times a week but other days its failure is almost constant.
It generally fails on one of the Paste Special Commands. ( fails on Different ones )
Thanks for Looking. Heres my Code.

Sub OpenToSold5()
' OpentoSold Macro Moves Sold Items from Amz Open to Sold and Pastes _
  the Description at the Cursor in the open AmazonSale Word Doc.

   'Macro recorded 2/1/2008 by Mike

   ' Keyboard Shortcut: Ctrl+Shift+W

Dim lRow As Long
Dim lCol As Long

Dim lCurrRow As Long
Dim wActSht As Worksheet
Set wActSht = ActiveSheet
lCurrRow = ActiveCell.Row

Rows(ActiveCell.Row).Cut
Windows("AMZ-GM Sold.xlsm").Activate
lRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row 'This gets the last row from Sold.xls
ActiveSheet.Cells(lRow + 1, 1).Activate 'Add 1 to the last row for first blank row
ActiveSheet.Paste

wActSht.Rows(lCurrRow).RowHeight = 40

Cells(ActiveCell.Row, 26).Copy ' Copy Z--- 26 = z


Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Set WDApp = GetObject(, "Word.Application") ' Reference active document
Set WDDoc = WDApp.ActiveDocument
WDApp.Selection.PasteSpecial
    WDApp.Selection.InsertParagraph
  
WDApp.Visible = True 'This should leave Word Open

With WDApp.Selection.Find
    .text = "------"
           .Execute
End With


 WDApp.Selection.MoveDown Unit:=wdLine, Count:=1
Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 19).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True


WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 43).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True

WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 41).Copy
WDApp.Selection.PasteSpecial


WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 18).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True

WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 16).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True

WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 17).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True

WDApp.Selection.MoveUp Unit:=wdLine, Count:=1
WDApp.Selection.EndKey Unit:=wdLine
WDApp.Selection.TypeText text:="   -   "

Windows("AMZ-GM Sold.xlsm").Activate
Cells(ActiveCell.Row, 50).Copy
WDApp.Selection.PasteSpecial
WDApp.Visible = True


WDApp.Visible = True 'This should leave Word Open

' Clean up
Set WDDoc = Nothing
Set WDApp = Nothing
Application.WindowState = xlMinimized

End Sub