I am trying to create a macro that will use data from Excel to create a Word doc and I came across this. Almost everything seems to work exactly as I want it to with 2 exceptions.
- For some reason it leaves a blank line at the top of the Word doc. I've tried several different things, but I can't seem to get rid of it.
- I'm trying to insert a hyperlink for an email address, but every method I try simply does nothing.
If anyone can offer some guidance I'd really appreciate it.
Here's my code, as it stands now:
Code
Sub AddData1()
'from http://www.ozgrid.com/forum/showthread.php?t=19553
' Creates Word document
Dim WordApp As Object
Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'data sort -- will need for For/i loop to begin after this statement
' Cycle through all records on Sheet1
Records = ActiveSheet.UsedRange.Rows.Count - 1
For i = 1 To Records
' Start Word And create an Object
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With
' Determine the file name
SaveAsName = ThisWorkbook.Path & "\" & "TestFile.docx" 'replace with applicant/market/band
' Information from worksheet
Set Data = Sheets("Sheet1").Range("A2")
' Update status bar progress message
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Processing Record " & i & " of " & Records
' Assign current data To variables
APPLICANT = Data.Offset(i - 1, 0).Value 'letter
MARKET = Data.Offset(i - 1, 1).Value 'number
BAND = UCase(Data.Offset(i - 1, 2).Value) 'title
'Descript = Data.Offset(i - 1, 3).Value
'FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
'FMText = Data.Offset(i - 1, 5).Value
'Donor = Data.Offset(i - 1, 6).Value
' Send commands To Word
With WordApp
With .Selection
With .PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
.Font.Name = "Times New Roman"
'Frequency Coordinator, address, contact
.TypeParagraph
.ParagraphFormat.Alignment = 2
.Font.Size = 14
.Font.Bold = True
.TypeText Text:="Name" & Chr(11)
.Font.Size = 12
.Font.Bold = False
.TypeText Text:="Address" & Chr(11)
.TypeText Text:="City, State, Zip" & Chr(11)
.TypeText Text:="Phone" & Chr(11)
.TypeText Text:="Email: [email protected]" & Chr(11) 'still not working
'ActiveDocument.Hyperlinks.Add Anchor:=LINK.Range, Address:= _
'"[email protected]", SubAddress:="", ScreenTip:="", TextToDisplay:= _
'"[email protected]"
'horizontal line
'date
.TypeParagraph
With .ParagraphFormat
.Alignment = 0
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleThinThickSmallGap
.LineWidth = wdLineWidth300pt
.Color = wdColorAutomatic
End With
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
.TypeText Text:=Chr(11) & TODAYDATE & Chr(11)
'title
.TypeParagraph
.ParagraphFormat.Alignment = 1
.Font.Size = 18
.Font.Bold = True
.Font.Underline = True
.TypeText Text:="This is my Title"
.Font.Size = 12
.Font.Bold = False
.Font.Underline = False
'body
.TypeParagraph
.ParagraphFormat.Alignment = 0
.TypeText Text:="blah, blah -- letter content"
End With
End With
' Save the Word file And Close it -- will need to move Word creation/save to within For/i loop
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With
Set WordApp = Nothing
Next i
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Display More
As a side note, this has been redacted a bit to remove some info that shouldn't be posted publicly and I know that this is set up to create a separate document for each row on the spreadsheet and that it replaces each sheet when it saves so I'll only see one sheet. For now, this is as intended.
Thanks in advance for any assistance.