Evolved Macro is Failing Intermitently - need help to modernize please

mstuf

Active Member
Joined
Feb 4, 2003
Messages
316
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.

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
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,141,316
Messages
5,705,708
Members
421,406
Latest member
kluna90

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top