Sub toWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Set Wkbk1 = ActiveWorkbook


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

For Each ws In ActiveWorkbook.Worksheets
    ws.Range("A1:A2").Copy
    Dim wdapp As Object
    Dim wddoc As Object
    Dim Header As Range
    Dim strdocname As String
   
    'file name & folder path
    On Error Resume Next
    'error number 429
    Set wdapp = GetObject(, "Word.Application")
    If Err.Number = 429 Then
        Err.Clear
        'create new instance of word application
        Set wdapp = CreateObject("Word.Application")
    End If
    wdapp.Visible = True
    'define paths to file
    strdocname = "C:\Name.doc"
    If Dir(strdocname) = "" Then
        MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Name.doc", _
        vbExclamation, "The document does not exist "
        Exit Sub
    End If

    wdapp.Activate
    Set wddoc = wdapp.Documents(strdocname)
    If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname)

    'must activate to be able to paste
    wddoc.Activate
    wddoc.Range.Paste
    
    Next ws
    
    'Clean up
    Set wddoc = Nothing
    Set wdapp = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub