Copy/Paste Multiple cells from Excel to Word

[lo_rah via OfficeKB.com]

Hello,
I'm new at VBA and have been polking around looking for some answers but
haven't found them yet. The code I'm using is listed below. Basically what
I want to do is copy cell B2 into word as a heading 1, cell C2 as a heading 2,
D2 as heading 3, and G2 as body text. I figured I would need to have two
macros, one to bring the text into word from excel and one to change the
style of the text to the correct heading/body text arrangement.

The problem I'm having with the code from excel that I'm using is that it is
pasting over what was previously brought it so i'm only left with the the
text for D2 and nothing else. I tried to make it add a paragraph at the end
of each so that it wouldn't overwrite it, but what's happening is the text is
being selected and pasted over each time. I don't know really anything about
VBA so anything I try is like a stab in the darkness. In order to get the
code to copy and past all 4 cells in a row i repeated the following code
which is opening the word doc and i think that's where the problem is. I
just don't know how to fix it:

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0

Set wdDoc = wdApp.Documents.Open(fNameAndPath)
wdApp.Visible = True

I don't know if i'm going to need to use bookmarks to keep this from
happening, or if there is another way. Also, I need a solution that would
work with a loop, because i will need to loop this code until the frist blank
row.

Laura

The code:

Dim wdApp As Object
Dim wdDoc As Object
Dim fNameAndPath As String


fNameAndPath = "C:\data\Test.doc"

ActiveSheet.Range("B2:B2").Copy

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0

Set wdDoc = wdApp.Documents.Open(fNameAndPath)
wdApp.Visible = True

With wdDoc.Content
.Font.Name = "Tahoma"
.Font.Size = 20
.PasteSpecial DataType:=wdPasteText
End With

ActiveDocument.Content.InsertParagraphAfter

Workbooks("test.xls").Activate
ActiveSheet.Range("C2:C2").Copy

AppActivate "Microsoft Word"

With wdDoc.Content
.Font.Name = "Tahoma"
.Font.Size = 18
.PasteSpecial DataType:=wdPasteText
End With

ActiveDocument.Content.InsertParagraphAfter

Workbooks("test.xls").Activate
ActiveSheet.Range("D22").Copy

AppActivate "Microsoft Word"

With wdDoc.Content
.Font.Name = "Tahoma"
.Font.Size = 16
.PasteSpecial DataType:=wdPasteText
End With

ActiveDocument.Content.InsertParagraphAfter

Workbooks("test.xls").Activate
ActiveSheet.Range("G2:G2").Copy

AppActivate "Microsoft Word"

With wdDoc.Content
.Font.Name = "Tahoma"
.Font.Size = 14
.PasteSpecial DataType:=wdPasteText
End With

ActiveDocument.Content.InsertParagraphAfter

End Sub