AppActivate does not work

[DKyr]

Hello,

i want to copy every cell in an Excel range (which is every time different, so i can not copy a range) und paste each cell it to a Word File. I get the message that the AppActivate does not work :(. Below my function.


Private Sub Nach_Click()
Dim i As Integer
Dim LastRowColA As Long
Dim AnwiD As Double
LastRowColA = Range("A65536").End(xlUp).Row
For i = 3 To LastRowColA
DoEvents
Range("A" & i).Copy
AppActivate "Word"
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues
SendKeys "{enter}"
AppActivate ("MicroSoft Excel")
Workbooks("Matchcodes Dimitri 4.1").Activate
Next
SendKeys ("11")
AppActivate "word"
End Sub


Thank you,

Dkyr

[snb]

Sub M_snb()
columns(1).specialcells(2).offset(2).specialcells(2).copy

getobject("Matchcodes Dimitri 4.1.docx").content.range.paste
End Sub

[DKyr]

thnks for your reply!
It didn´t paste the cells to the Word document too.

[Kenneth Hobs]

Obviously, you need to change c:\myfiles\msword\ken.docx to your docx file that is open.


Sub snb_ken()
Dim wdDoc As Object, wdApp As Object
Columns(1).SpecialCells(2).Offset(2).SpecialCells(2).Copy
Set wdDoc = GetObject("c:\MyFiles\MSWord\ken.docx")
Set wdApp = GetObject(, "Word.Application")
With wdDoc
.Paragraphs(.Paragraphs.Count).Range.Paste
End With
With wdApp
.Selection.EndKey Unit:=6 'wdStory
.Selection.TypeParagraph
.Selection.TypeText Text:="11"
.Activate
End With
End Sub

[snb]

this does:
Provided you adapt "G:\OF\docleeg.docx" to an existing Word file in your system.


Sub M_snb()
thisworkbook.sheet1.Columns(1).SpecialCells(2).Offset(2).SpecialCells(2).Co py
with GetObject("G:\OF\docleeg.docx")
.Content.Paste
.Windows(1).Visible = True
end with
End Sub

[DKyr]

this does:
Provided you adapt "G:\OF\docleeg.docx" to an existing Word file in your system.


Sub M_snb()
thisworkbook.sheet1.Columns(1).SpecialCells(2).Offset(2).SpecialCells(2).Co py
with GetObject("G:\OF\docleeg.docx")
.Content.Paste
.Windows(1).Visible = True
end with
End Sub

Thank you, the value has been pasted to word, but the loop doesn´t stop and overwrites the previous pasted values. Below the code with your proposal integraded.


Private Sub Nach_Click()
Dim i As Integer
Dim LastRowColA As Long
LastRowColA = Sheets("Sheet2").Range("A65536").End(xlUp).Row
For i = 2 To LastRowColA
If LastRowColA > 0 Then
DoEvents
Range("A" & i).Copy
End If
With GetObject("C:\Users\kyriakos\Documents\Matchcodes Dimitri 4.1.docx").Content.PasteSpecial
SendKeys "{enter}"
End With
Next
SendKeys "{enter}"
End Sub

[snb]

In my code is no loop and you don't need any.
My code is all you need.
The only thing you have to do is adapt the file name.


Sub M_snb()
thisworkbook.sheets("sheet2").Columns(1).SpecialCells(2).Offset(2).SpecialCells(2).Copy
With GetObject("G:\OF\docleeg.docx")
.Content.Paste
.Windows(1).Visible = True
End With
End Sub