Help with VBA code extracting Excel data to word

[martman]

Please help I am trying to create a module with VBA to extract data from Excel to MS Word. I tried to modify the " make memo " from Excel 2007 power programing. Could someone take a look and give me some pointers?

Sub Button4_Click()
' Creates memos in word using Automation (late binding)
Dim wdApp As Object
Dim wrdDoc As Object
Dim Sh As Object
Dim Data As Range, message As String
Dim r As Long
Dim Acct As String, Firstn As String, Lastn As String, Med As String, Disp As String, Sig As String, Refills As String, SpecialI As String, Days As String
Dim Provider As String
Dim SaveAsName As String

' Start Word and create an object
Set wdApp = CreateObject("Word.Application.12")
wdApp.Visible = True
Set wrdDoc = wdApp.Documents.Add
Set Sh = Worksheets("Rx Writer").Range("Medication")

' Information from worksheet Const
With Sh
Set Data = .Worksheets("Rx Writer").Range("Medication")
message = .Worksheets("Rx Writer").Range("message")
End With
' Cycle through all records in Sheet1

r = Application.WorksheetFunction. _
CountA(Range("Medication")) + 1


On Error Resume Next


' Assign current data to variables
Acct = Worksheets("Sheet1").Range("'Rx Writer'!$C$2").Value
Firstn = Worksheets("Sheet1").Range("'Rx Writer'!$B$2").Value
Lastn = Worksheets("Sheet1").Range("'Rx Writer'!$A$2").Value
Med = Data.Cells(r, 5).Value
Disp = Data.Cells(r, 6).Value
Sig = Data.Cells(r, 7).Value
Refills = Data.Cells(r, 8).Value
SpecialI = Data.Cells(r, 9).Value
Provider = Worksheets("Sheet1").Range("'Rx Writer'!$K$2").Value
Days = Data.Cells(r, 12).Value

' Determine the file name
SaveAsName = Application.DefaultFilePath & "\" & Acct & vbTab & ".docx"
' Send commands to Word
With wrdDoc
.Selection
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.TypeText Text:="Community Care"
.Font.Size = 8
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.TypeText Text:="Urgent Care & Family Practice"
.TypeText Text:="1595 Yellowstone Ave."
.TypeText Text:="Pocatello, Idaho 83201"
.ParagraphFormat.Alignment = 0
.TypeParagraph
.TypeText Text:="Date:" & vbTab & _
Format(Date, "mmmm d, yyyy") & "Acct #:" & vbTab & Acct & "Name:" & vbTab & Firstn & "" & Lastn & vbTab
End With
With Data
For r = 1 To r
wrdDoc.Application.StatusBar = "Processing Records" & r
.TypeParagraph
.TypeParagraph
.Font.Size = 10
.ParagraphFormat.Alignment = 0
.Font.Bold = False
.TypeText Text:="Rx:" & vbTab & Med & "Disp:" & vbTab & Disp
.TypeParagraph
.TypeText Text:="Sig:" & vbTab & Sig & "for" & vbTab & Days
.TypeParagraph
.TypeText Text:="Refills:" & vbTab & Refills
.TypeText Text:="Special Instructions:" & vbTab & SpecialI
Next r
End With
With wrdDoc
.Selection
.TypeParagraph
.TypeText message
.TypeParagraph
.TypeText Text:="Provider:" & vbTab & Provider
.TypeParagraph
.TypeText Text:="Please call 208.232.0032 with any questions"
End With







'
' Reset status bar
Application.StatusBar = ""

wdApp.Quit
Set wdApp = Nothing
' Reset status bar
Application.StatusBar = ""
MsgBox r & " memos were created and saved in " & Application.DefaultFilePath

' Show the folder
Shell "explorer.exe " & Application.DefaultFilePath, vbNormalFocus


End Sub