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

[tommyonegun]

I have the vba worked out to create the appointment with no issues.

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.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[/TR]
[TR]
[TD]Client[/TD]
[TD]Task Detail[/TD]
[TD]Hrs[/TD]
[TD]Day[/TD]
[TD][/TD]
[TD]Meeting Day[/TD]
[/TR]
[TR]
[TD]Client 1[/TD]
[TD]Task 1[/TD]
[TD]2[/TD]
[TD]Monday[/TD]
[TD][/TD]
[TD]Monday[/TD]
[/TR]
[TR]
[TD]Client 2[/TD]
[TD]Task 2[/TD]
[TD]3[/TD]
[TD]Monday[/TD]
[TD][/TD]
[TD]Tuesday[/TD]
[/TR]
[TR]
[TD]Client 3[/TD]
[TD]Task 3[/TD]
[TD]1[/TD]
[TD]Monday[/TD]
[TD][/TD]
[TD]Wednesday[/TD]
[/TR]
[TR]
[TD]Client 4[/TD]
[TD]Task 4[/TD]
[TD]4[/TD]
[TD]Monday[/TD]
[TD][/TD]
[TD]Thursday[/TD]
[/TR]
[TR]
[TD]Client 5[/TD]
[TD]Task 5[/TD]
[TD]4[/TD]
[TD]Tuesday[/TD]
[TD][/TD]
[TD]Friday[/TD]
[/TR]
[TR]
[TD]Client 6[/TD]
[TD]Task 6[/TD]
[TD]3[/TD]
[TD]Tuesday[/TD]
[TD][/TD]
[TD]Saturday[/TD]
[/TR]
[TR]
[TD]Client 7[/TD]
[TD]Task 7[/TD]
[TD]2[/TD]
[TD]Tuesday[/TD]
[TD][/TD]
[TD]Sunday[/TD]
[/TR]
[TR]
[TD]Client 8[/TD]
[TD]Task 8[/TD]
[TD]2[/TD]
[TD]Wednesday[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Client 9[/TD]
[TD]Task 9[/TD]
[TD]1[/TD]
[TD]Wednesday[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[tommyonegun]

Can anyone help here?

 

[tommyonegun]

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.

 

[daverunt]

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.

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

 

[tommyonegun]

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.

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></o>

 

[daverunt]

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.

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

 

[daverunt]

Comment error.

'Specify Table sheet name
    TableSht = ActiveSheet.Name

 

[daverunt]

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.

.Selection.PasteExcelTable False, False, False