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]

Please, do not quote !!

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

Grasping the fundamentals of VBA by studying a book wouldn't be a bad idea.