Grab rows if meets criteria, and put them in body of Outlook appointment.

tommyonegun

New Member
Joined
Aug 20, 2015
Messages
25
I have the vba worked out to create the appointment with no issues.
Code:
Sub Makeapt()

Dim warning
warning = MsgBox("You are about to create Outlook appointments for " & ActiveCell.Value & " " & Cells(ActiveCell.Row, 10) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub

Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 10)
Set myApt = myOutlook.createitem(1)

myApt.Subject = ID & " " & Cells(ActiveCell.Row, 7) & " Hours Booked"
myApt.Start = Cells(ActiveCell.Row, 10) & " 6:00:00 PM"
myApt.End = Cells(ActiveCell.Row, 10) & " 7:00:00 PM"
myApt.Body = "Tasks"
myApt.Save

End Sub

It works great. Where I get lost is myApt.Body = "Tasks". That's just a place holder for now. What I want to do is grab every row, columns A:D, where the value in D equals ActiveCell.Value, and list those results in the body of the email instead of "Tasks". I've tried a few things and searched the forum with no results. Any help would be greatly appreciated. An example of the Spreadsheet is below. In the real sheet there is a bunch of data off to the right. Essentially I highlight the day of the week I'm creating the meeting for in Column F, and run the Macro. It confirms the date and creates a summary meeting with the total hours for that day in the Subject. Now I just need the other detail in the body of the meeting.

ABCDEF
ClientTask DetailHrsDayMeeting Day
Client 1Task 12MondayMonday
Client 2Task 23MondayTuesday
Client 3Task 31MondayWednesday
Client 4Task 44MondayThursday
Client 5Task 54TuesdayFriday
Client 6Task 63TuesdaySaturday
Client 7Task 72TuesdaySunday
Client 8Task 82Wednesday
Client 9Task 91Wednesday

<tbody>
</tbody>
 
Last edited:

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Can anyone help here?
Just checking in to see if anyone is able to help.

I've continued to research and experiment to no avail. It seems as though it should be pretty easy. If I ever do come up with a solution, I'll post it here. It seems my VBA just isn't good enough to make this happen.
 
Upvote 0
Hi,

You mentioned e-mail but the Tasks placeholder is part of the appointment code so I assume you mean appointment?

Try this ( on a copy of your workbook) to see if it gets near what you are after.
It finds each row in D with the day selected in F and appends the content of A to D of each row found to a fRw string
It adds up the hours in C and puts the figure in the subject.
The MsgBox code for the rows is so you can check it's picking up the required info/rows and you can delete or comment out as required.

The Body content isn't particularly impressive but I haven't played much with Appointments so no idea how to make the info prettier.

Code:
Sub Makeapt()

Dim warning


warning = MsgBox("You are about to create Outlook appointments for " & ActiveCell.Value & " " & Cells(ActiveCell.Row, 10) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub

Set Rng = Range(Range("D3"), Range("D" & Rows.Count).End(xlUp))


 sVal = ActiveCell.Value
 
 For Each Cell In Rng
 If Cell.Value = sVal Then
 

 Rw = Cell.Offset(0, -3).Value & "   " & Cell.Offset(0, -2).Value & "   " & Cell.Offset(0, -1).Value & "   " & sVal
 
 Hrs = Hrs + Cell.Offset(0, -1).Value
 fRw = fRw & vbNewLine & Rw
 
 MsgBox fRw
 End If
 Next

If Len(fRw) = 0 Then
MsgBox ("No " & sVal & " found in list")
Exit Sub
End If

Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 10)
Set myApt = myOutlook.createitem(1)

myApt.Subject = ID & " " & Cells(ActiveCell.Row, 7) & Hrs & " Hours Booked"
myApt.Start = Cells(ActiveCell.Row, 10) & " 6:00:00 PM"
myApt.End = Cells(ActiveCell.Row, 10) & " 7:00:00 PM"


myApt.Body = fRw

myApt.Save


End Sub
 
Last edited:
Upvote 0
Hi,

You mentioned e-mail but the Tasks placeholder is part of the appointment code so I assume you mean appointment?

Try this ( on a copy of your workbook) to see if it gets near what you are after.
It finds each row in D with the day selected in F and appends the content of A to D of each row found to a fRw string
It adds up the hours in C and puts the figure in the subject.
The MsgBox code for the rows is so you can check it's picking up the required info/rows and you can delete or comment out as required.

The Body content isn't particularly impressive but I haven't played much with Appointments so no idea how to make the info prettier.

Code:
Sub Makeapt()

Dim warning


warning = MsgBox("You are about to create Outlook appointments for " & ActiveCell.Value & " " & Cells(ActiveCell.Row, 10) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub

Set Rng = Range(Range("D3"), Range("D" & Rows.Count).End(xlUp))


 sVal = ActiveCell.Value
 
 For Each Cell In Rng
 If Cell.Value = sVal Then
 

 Rw = Cell.Offset(0, -3).Value & "   " & Cell.Offset(0, -2).Value & "   " & Cell.Offset(0, -1).Value & "   " & sVal
 
 Hrs = Hrs + Cell.Offset(0, -1).Value
 fRw = fRw & vbNewLine & Rw
 
[COLOR=#ff0000] MsgBox fRw[/COLOR]
 End If
 Next

If Len(fRw) = 0 Then
MsgBox ("No " & sVal & " found in list")
Exit Sub
End If

Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 10)
Set myApt = myOutlook.createitem(1)

myApt.Subject = ID & " " & Cells(ActiveCell.Row, 7) & Hrs & " Hours Booked"
myApt.Start = Cells(ActiveCell.Row, 10) & " 6:00:00 PM"
myApt.End = Cells(ActiveCell.Row, 10) & " 7:00:00 PM"


myApt.Body = fRw

myApt.Save


End Sub

This is great. I removed the MsgBox fRw so that there wasn't a prompt for every row it was inserting. It worked perfectly.
The only thing that could even be improved is the formatting. It reads like this once the appointment is created:

AWU Meeting to discuss things .75 Friday
Smith ODAC help. 1 Friday
Test Client Website enhancement work. Really long task. 1 Friday
Internal PM communications 1 Friday


Is there a way to maybe format this as a table?

If not, no big deal. This is a million times better than what I was able to come up with. Thanks a ton. This really helped immensely. <o:p></o:p>
 
Last edited:
Upvote 0
Hi,

All new code as a lot has changed.

Having looked at the options I've settled on this bit of cobbled code. I make no apologies for the code used : )

Appointments are in RTF, but having looked at RTF tags for coding a table then adding the content - I think I was wise enough to give that a wide berth.

Copying a UsedRange and pasting with the Word Formats available didn't copy the format of the cells across so they were wrapped in some of the cells. Setting the wrapping to false still gave unsatisfactory results.
I couldn't find any reference on how to paste a selection using 'UseDestinationStyles', that worked (It is available for manual pasting), in VBA, which would have worked.

So the final attempt was to copy the info across as an Excel table, as I found a reference for that. So to do that required a few steps. (Somebody might shorten/tidy my code for you).

The code:
1. adds a new sheets.
2 Copies valid rows across
3. Inserts the header as row 1
4. Converts the rows to a table - assuming columns are A to D.
5. Copies the table
6. Uses the Word Editor to paste it as an Excel Table into the appointment
7. Deletes the added sheet without confirmation.

Code:
Sub Makeapt_With_Word()
Dim warning
warning = MsgBox("You are about to create Outlook appointments for " & ActiveCell.Value & " " & Cells(ActiveCell.Row, 10) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub

'Add a sheet to copy the rows to
    TableSht = ActiveSheet.Name

'Add new Sheet and get name
ActiveWorkbook.Sheets.Add
    AddSht = ActiveSheet.Name

'Go back to Table sheet and set the range as column D
Worksheets(TableSht).Activate
    Set Rng = Range(Range("D3"), Range("D" & Rows.Count).End(xlUp))

'Gives the selected Day
SelDay = ActiveCell.Value

For Each Cell In Rng
    CellRow = Cell.Row
'If the row includes selected day copy to the new sheet
If Cell.Value = SelDay Then

'Add the copied rows to row 2 onward
Rw = Sheets(AddSht).Cells(Rows.Count, "B").End(xlUp).Row + 1
    Range(Cells(CellRow, 1), Cells(CellRow, 4)).Copy Destination:=Sheets(AddSht).Range("A" & Rw)

'Total the hours
    Hrs = Hrs + Cell.Offset(0, -1).Value
End If
Next

'Copy Header Row to the added sheet
    Range(Cells(2, 1), Cells(2, 4)).Copy Destination:=Sheets(AddSht).Range("A1")

'Construct appointment
Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 10)
    Set MyApt = myOutlook.createitem(1)
    MyApt.Subject = ID & " " & Cells(ActiveCell.Row, 7) & Hrs & " Hours Booked"
MyApt.Start = Cells(ActiveCell.Row, 10) & " 6:00:00 PM"
    MyApt.End = Cells(ActiveCell.Row, 10) & " 7:00:00 PM"

'Activate the Added sheet and turn the range into a table
    Worksheets(AddSht).Activate

    With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.ListObjects.Add(xlSrcRange, Range("$A$1:$D$" & LastRow), , xlYes).Name = _
"Table1"
.ListObjects("Table1").Range.Copy
    End With

'Paste the table into the appointment
MyApt.Display
    MyApt.GetInspector.WordEditor.Windows(1).Selection.PasteExcelTable False, True, False

MyApt.Save

'Delete the added sheet without confirmation
Application.DisplayAlerts = False
Sheets(AddSht).Delete
    Application.DisplayAlerts = True
End Sub
 
Last edited:
Upvote 0
Code:
Comment error.

'Specify Table sheet name
    TableSht = ActiveSheet.Name
 
Upvote 0
Also if you want the excel table format copied try changing True to False in this bit of code, otherwise you get Word formatting, which I preferred.
Code:
.Selection.PasteExcelTable False, False, False
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top