Can the following macro be converted to work with Excel instead of Word? Can contact address, city, state and zip be added as well as 3 additional blank columns?
Thanks
Thanks
VBA Code:
Public Sub InsertDataFromOutlook()
Dim strForename As String
Dim strSurname As String
Dim strAddress As String
Dim strHomePhone As String
Dim strCellPhone As String
Dim oTable As Table
Dim oRng As Range
'Set up the formatting codes in strCode
strForename = "<PR_GIVEN_NAME>"
strSurname = "<PR_SURNAME>"
strHomePhone = "<PR_HOME_TELEPHONE_NUMBER>"
strCellPhone = "<PR_CELLULAR_TELEPHONE_NUMBER>"
strAddress = "<PR_EMAIL_ADDRESS>"
'Let the user choose the name in Outlook
strSurname = Application.GetAddress("", strSurname, _
False, 1, , , True, True)
If strSurname = "" Then
MsgBox "User cancelled or no name listed", , "Cancel"
GoTo lbl_Exit
End If
strForename = Application.GetAddress("", strForename, _
False, 2, , , True, True)
strHomePhone = Application.GetAddress("", strHomePhone, _
False, 2, , , True, True)
strCellPhone = Application.GetAddress("", strCellPhone, _
False, 2, , , True, True)
strAddress = Application.GetAddress("", strAddress, _
False, 2, , , True, True)
If ActiveDocument.Tables.Count = 0 Then
Set oTable = ActiveDocument.Tables.Add(ActiveDocument.Range, 1, 6)
Set oRng = oTable.Rows(1).Cells(1).Range
oRng.End = oRng.End - 1
oRng.Text = "Last Name"
Set oRng = oTable.Rows(1).Cells(2).Range
oRng.End = oRng.End - 1
oRng.Text = "First Name"
Set oRng = oTable.Rows(1).Cells(3).Range
oRng.End = oRng.End - 1
oRng.Text = "Phone"
Set oRng = oTable.Rows(1).Cells(4).Range
oRng.End = oRng.End - 1
oRng.Text = "Cell"
Set oRng = oTable.Rows(1).Cells(5).Range
oRng.End = oRng.End - 1
oRng.Text = "Email Address"
Set oRng = oTable.Rows(1).Cells(6).Range
oRng.End = oRng.End - 1
oRng.Text = "Amount Paid"
Else
Set oTable = ActiveDocument.Tables(1)
End If
oTable.Rows.Add
Set oRng = oTable.Rows.Last.Cells(1).Range
oRng.End = oRng.End - 1
oRng.Text = strSurname
Set oRng = oTable.Rows.Last.Cells(2).Range
oRng.End = oRng.End - 1
oRng.Text = strForename
Set oRng = oTable.Rows.Last.Cells(3).Range
oRng.End = oRng.End - 1
oRng.Text = strHomePhone
Set oRng = oTable.Rows.Last.Cells(4).Range
oRng.End = oRng.End - 1
oRng.Text = strCellPhone
Set oRng = oTable.Rows.Last.Cells(5).Range
oRng.End = oRng.End - 1
oRng.Text = strAddress
lbl_Exit:
Set oRng = Nothing
Set oTable = Nothing
Exit Sub
End Sub
Private Sub Document_New()
End Sub