Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+w
'
    Dim objWord As Word.Application
    Dim wordDoc As Word.Document

    Application.ScreenUpdating = False
    Application.EnableEvents = False


    ActiveCell.Copy


    'Create an Instance of MS Word
    On Error Resume Next

    'Is MS Word already opened?
    Set WordApp = GetObject(class:="Word.Application")

    'Clear the error between errors
    Err.Clear

    'If MS Word is not already open then open MS Word
    If WordApp Is Nothing Then
        Set WordApp = CreateObject(class:="Word.Application")
        Application.Wait (Now + TimeValue("0:00:05"))
    End If



    'Handle if the Word Application is not found
    If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
    End If

  On Error GoTo 0

  'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
  Set wordDoc = WordApp.Documents.Add









'Paste Cell into MS Word



  Set Destination = wordDoc.Content
  Destination.Collapse Direction:=wdCollapseStart
  Destination.PasteSpecial DataType:=wdPasteText


EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False
End Sub