Sub MakeRegistrationForms()
' Creates Word document with one sheet for each member
' This assumes the worksheet only contains the members to include in the directory
'
' For some reason, the sort portion of this macro is failing so it is currently
' commented out until I get to try this again on another machine.
'
' In 2010, I separated the about to expire from the rest and printed them on
' yellow to draw attention to them. -MF
Application.ScreenUpdating = False
Dim WordApp As Object
Dim DataOption1
Const wdPageBreak = 7
' Start Word and create an object
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With
' Determine the file name
saveasname = ThisWorkbook.Path & "\" & "RegForms.doc"
Dim MemberSheet
MemberSheet = "Members"
Dim NameCol
NameCol = "lastfirst"
Dim Address1Col
Address1Col = "address1"
Dim Address2Col
Address2Col = "address2"
Dim CityCol
CityCol = "city"
Dim StateCol
StateCol = "state"
Dim CodeCol
CodeCol = "postalcode"
Dim CountryCol
CountryCol = "country"
Dim RenewCol
RenewCol = "notice"
Dim Phone1Col
Phone1Col = "phone1"
Dim Phone2Col
Phone2Col = "phone2"
Dim Email1Col
Email1Col = "email1"
Dim Email2Col
Email2Col = "email2"
Dim TnameCol
TnameCol = "trailname"
Dim TrailsCol
TrailsCol = "trails"
Dim GatheringCol
GatheringCol = "12Gathering"
Dim PDFCol
PDFCol = "PDF"
' Select the membership worksheet
Sheets(MemberSheet).Select
' Determine the last row and column of the worksheet
lr = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
lc = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
' Determine the column numbers for the membership data to be
' included in the Membership Index
For i = 1 To lc
Select Case Worksheets(MemberSheet).Cells(1, i).Value
Case NameCol
nc = i
Case Address1Col
a1c = i
Case Address2Col
a2c = i
Case CityCol
cic = i
Case StateCol
sc = i
Case CodeCol
zc = i
Case CountryCol
coc = i
Case RenewCol
rc = i
Case Phone1Col
p1c = i
Case Phone2Col
p2c = i
Case Email1Col
e1c = i
Case Email2Col
e2c = i
Case TnameCol
tnc = i
Case TrailsCol
tc = i
Case GatheringCol
gc = i
Case PDFCol
pdfc = i
End Select
Next i
' The following sort call worked on Scott's machine but not Benson's. I left it
' in in case it works on another machine.
' Sort the entire spreadsheet by the names column
'Range(Cells(1, 1), Cells(lr, lc)).Sort Key1:=Cells(1, nc), Order1:=xlAscending, _
header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
' Loop through all members to generate index information
For i = 2 To lr
' trap each piece of worksheet information
Name = Cells(i, nc).Value & vbCrLf
address1 = Cells(i, a1c).Value
address2 = Cells(i, a2c).Value
city = Cells(i, cic).Value
State = Cells(i, sc).Value
zip = Cells(i, zc).Value
country = Cells(i, coc).Value
renewal = Cells(i, rc).Value
phone1 = Cells(i, p1c).Value
phone2 = Cells(i, p2c).Value
email1 = Cells(i, e1c).Value
email2 = Cells(i, e2c).Value
tname = Cells(i, tnc).Value
trails = Cells(i, tc).Value
gathering = Cells(i, gc).Value
pdf = Cells(i, pdfc).Value
' Format each line of information for the Word document
If address1 <> "" Then
Address = address1
If address2 <> "" Then
Address = Address & vbCrLf & address2 & vbCrLf
Else
Address = Address & vbCrLf
End If
Else
Address = vbCrLf & "Address: ______________________________" & vbCrLf
End If
csz = city & ", " & State & " " & zip
If csz = ", " Then
csz = vbCrLf & "City, State, Zip: ______________________________" & vbCrLf
Else
csz = csz & vbCrLf
End If
If country <> "" Then
country = country & vbCrLf
Else
country = "" & vbCrLf
End If
renewalnote = "Your membership is " & renewal & "." & vbCrLf & vbCrLf
If phone1 <> "" Then
phone1 = phone1 & vbCrLf
Else
phone1 = "Phone: ______________________________" & vbCrLf
End If
If phone2 <> Empty Then
phone2 = phone2 & vbCrLf
Else
phone2 = "" & vbCrLf
End If
If email1 <> "" Then
email1 = email1 & vbCrLf
Else
email1 = vbCrLf & "Email: ______________________________" & vbCrLf
End If
If email2 <> "" Then
email2 = email2 & vbCrLf
Else
email2 = "" & vbCrLf
End If
dqt = Chr(34) ' double quote symbol
If tname <> "" Then
tname = dqt & tname & dqt & vbCrLf & vbCrLf
Else
tname = "_____________________________" & vbCrLf & vbCrLf
End If
If trails <> "" Then
trails = "Trails completed: " & trails & vbCrLf & vbCrLf
Else
trails = vbCrLf & "Trails completed: _____________________________" & vbCrLf & vbCrLf
End If
If gathering <> "" Then
gathering = " Number of prepaid registrants: " & gathering & vbCrLf
Else
gathering = " Number of prepaid registrants: 0" & vbCrLf & vbCrLf
End If
If pdf <> "" Then
pdf = "Thank you for choosing to receive your newsletters in PDF format. "
Else
pdf = "_____ Check here to receive your newsletters in PDF format. "
End If
' Send commands to Word and write each line of data to file
With WordApp
With .Selection
.TypeParagraph
.Font.Name = "Arial"
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.typetext Text:="Welcome to the ALDHA Gathering!"
.TypeParagraph
.TypeParagraph
.typetext Text:="This is YOUR membership record with ALDHA:"
.TypeParagraph
.TypeParagraph
.Font.Size = 12
.ParagraphFormat.Alignment = 0
.typetext Text:="Is the information below correct? If NOT, please note changes here:"
.TypeParagraph
.TypeParagraph
.Font.Size = 12
.Font.Bold = True
.typetext Text:=Name
.Font.Bold = False
.Font.Size = 11
.typetext Text:=Address
.typetext Text:=csz
.typetext Text:=country
.typetext Text:=phone1
.typetext Text:=phone2
.typetext Text:=email1
.typetext Text:=email2
.typetext Text:=vbCrLf & "Trail name(s): "
.Font.Italic = True
.typetext Text:=tname
.Font.Italic = False
.typetext Text:=trails
.Font.Bold = True
.typetext Text:=renewalnote
If renewal <> "PAID THROUGH LIFE" And renewal <> "HONORARY LIFE MEMBER" Then
.ParagraphFormat.Alignment = 3
.typetext Text:="Membership renewals "
.Font.Bold = False
.typetext Text:="are $10 per calendar year per individual or household," & vbCrLf & vbCrLf
.Font.Bold = True
.typetext Text:="Lifetime Memberships "
.Font.Bold = False
.typetext Text:="are $200, and do not include yearly Gathering fees" & vbCrLf & vbCrLf
.ParagraphFormat.Alignment = 2
.typetext Text:=" Number of years: ________ x $10 per year = $_________" & vbCrLf & vbCrLf
.typetext Text:=" Lifetime membership is $200 $_________" & vbCrLf & vbCrLf
End If
.Font.Bold = True
.ParagraphFormat.Alignment = 3
.typetext Text:="Gathering registration "
.Font.Bold = False
.typetext Text:="is $20.00 per person, or $50 for a family of 3 or more. (kids over 13)" & vbCrLf & vbCrLf
.ParagraphFormat.Alignment = 1
.typetext Text:=gathering
.ParagraphFormat.Alignment = 2
.typetext Text:=" Number of registrants paid for today: ________ x $20 per person = $_________" & vbCrLf & vbCrLf
.ParagraphFormat.Alignment = 2
.typetext Text:=" Amount of donation $_________" & vbCrLf & vbCrLf
.Font.Bold = True
.typetext Text:="Total paid to ALDHA today: $_________" & vbCrLf & vbCrLf & vbCrLf
.Font.Bold = False
.ParagraphFormat.Alignment = 1
.Font.Bold = True
.typetext Text:="Donations to ALDHA"
.Font.Bold = False
.typetext Text:=", a registered 501(c)3 non-profit organization, are tax deductible." & vbCrLf & vbCrLf
.typetext Text:="Make checks payable to ALDHA." & vbCrLf & vbCrLf
.Font.Bold = True
.typetext Text:=pdf
.Font.Bold = False
.typetext Text:="PDF newsletters arrive earlier, in full color, are better for the environment, and help keep ALDHA's expenses down." & vbCrLf & vbCrLf
.InsertBreak Type:=wdPageBreak
End With
End With
Next i
With WordApp
.ActiveDocument.SaveAs Filename:=saveasname
.ActiveWindow.Close
End With
Set WordApp = Nothing
Application.ScreenUpdating = True
End Sub