Create dynamic table in apointment body

[jag108]

Hi Team Mr Excel!

I have an interesting situation that I am trying to find a resolution for, I really hope it can be done using VBA."

Anyway here goes. I have a sheet with a list of servers, these servers are auto patched based on Active Directory groups.

With the help From the Mr Excel experts, I have managed to calculate the next date a server(s) will be patched. Not all servers are patched on the same day, but then again there may be more than one server patched on the same day.

APG_CLAS.xlsm
	A	B	C	D	E	F	G
1	Host	Patching Group (Rule)	Schedule	Day	Occurance	Current Date	Next Due Date
2	Server1	APG-DevTest-ThirdFri-9amTo11am	Third Fri	5	3	14/07/2020	17/07/2020
3	Server2	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
4	Server3	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
5	Server4	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
6	Server5	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
7	Server6	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
8	Server7	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
9	Server8	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
10	Server9	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
11	Server10	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
12	Server11	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
13	Server12	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
14	Server13	APG-DevTest-ThirdSun-2amTo4am	Third Sun	7	3	14/07/2020	19/07/2020
15	Server14	APG-Prod-FirstSun-2amTo4am	First Sun	7	1	14/07/2020	02/08/2020
16	Server15	APG-Prod-FirstSun-2amTo4am	First Sun	7	1	14/07/2020	02/08/2020
17	Server16	APG-Prod-FirstSun-2amTo4am	First Sun	7	1	14/07/2020	02/08/2020
18	Server17	APG-Prod-FirstSun-2amTo4am	First Sun	7	1	14/07/2020	02/08/2020
19	Server18	APG-Prod-FirstSun-2amTo4am	First Sun	7	1	14/07/2020	02/08/2020
20	Server19	APG-Prod-FirstWed-2amTo3am	First Wed	3	1	14/07/2020	05/08/2020
21	Server20	APG-Prod-FirstWed-2amTo3am	First Wed	3	1	14/07/2020	05/08/2020
22	Server21	APG-Prod-FirstWed-2amTo3am	First Wed	3	1	14/07/2020	05/08/2020
23	Server22	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
24	Server23	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
25	Server24	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
26	Server25	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
27	Server26	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
28	Server27	APG-Prod-FourthSun-0amTo2am	Fourth Sun	7	4	14/07/2020	26/07/2020
29	Server28	APG-Prod-FourthSun-2amTo4am	Fourth Sun	7	4	14/07/2020	26/07/2020
30	Server29	APG-Prod-FourthSun-2amTo4am	Fourth Sun	7	4	14/07/2020	26/07/2020
Sheet2

Cell Formulas
Range	Formula
F23:F27,F2:F14	F2	=NOW()
G2:G30	G2	=INT((EOMONTH(F2,--(INT((F2-DAY(F2)+7-MOD(D2+1,7))/7)*7+MOD(D2+1,7)+(E2-1)*7<F2)-1)+7-MOD(D2+1,7))/7)*7+MOD(D2+1,7)+(E2-1)*7
F28:F30,F15:F22	F15	=TODAY()

Row 1 has a single server that is going to be patched on the 17th, this is fine, I can handle this.
How ever when we get to the situation whereby there are multiple servers to be patched on the 19th, I would ideally like to have the server names added into a list\table to be populated in the meeting request body.

I really hope this can be done?

 

[daverunt]

Hi,

I modified my email code from here, which created a single mail for Outlook for rows with same email addresses.

Email with rows included in VBA

Hi folks, Bit of a VBA novice. Would be grateful if anyone can help with the code. I have data like the below and I want to send one email to each unique email address in column E, copying in the address in column B. In the body of the email, I want to have all the rows for that country like...

www.mrexcel.com

Roughly
The macro looks for and deletes an AppBody sheet.
The macro copies the column header to AppBody
The macro loops down column G to get the first date.
Copies the row to AppBody
A second nested loop checks for the same date
Any rows with matching date are copied
A yes is appended to H on all copied rows so they are not processed again
AppBody content is auto fitted otherwise the date is just #######

The AppBody content is turned into Table 1 so it can be copied to the appointment using Word

The table is then unlisted and the content cleared

The Outlook appointment Code isn't something I use so you'll likely need to sort out the dates for that from cell.value and any other content missed.
I've just used something used before to check the table is copying based on next due date.
Happy to look if you post back.

If you don't want to send the whole rows take a shot at adjusting the code

Sub Make_App()


Dim AppBody As Range

Set mWs = Worksheets("Sheet2")

'If AppBody sheet already exists then delete it
If WorksheetExists("AppBody") Then
Application.DisplayAlerts = False
Worksheets("AppBody").Delete
Application.DisplayAlerts = True
End If

'Add a sheet to copy all same person rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "AppBody"

'Copy the header
   mWs.Rows(1).Copy Destination:=Worksheets("AppBody").Range("A1")

'Return to the appointment content sheet
   mWs.Activate

'Set due next date as range for first loop to run down
    Set rng = Range(Range("G2"), Range("G" & Rows.Count).End(xlUp))

'Get a row count to clear column H at the end
  i = rng.Rows.Count


For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 1).Value = "yes" Then

'Get the row number
    cRow = cell.Row

'Copy the row to the first empty row in the AppBody sheet
mWs.Range("A" & cRow, "G" & cRow).Copy Destination:=Sheets("AppBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
 

'Second loop checks the dates of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the AppBody sheet
    For Each dwn In rng.Offset(cRow - 1, 0)

    dRow = dwn.Row
    If dwn.Value = cell.Value Then

    dwn.Offset(0, 1).Value = "yes"

'Create additional table row for each extra row found
    mWs.Range("A" & dRow, "G" & dRow).Copy Destination:=Sheets("AppBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

    End If

    Next

'Autofit the copied rows on the new sheet, otherwise they'll be copied to the mail with defaults widths, heights
With Worksheets("AppBody")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set AppBody = .Range(.Cells(1, 1), .Cells(lRow, 7))
.Range("A1:G2").Columns.AutoFit
    End With


'Construct appointment
Set myOutlook = CreateObject("Outlook.Application")
'Set ID = "Identity"
Set MyApt = myOutlook.createitem(1)
MyApt.Subject = "Subject"
MyApt.Start = " 6:00:00 PM"
    MyApt.End = " 7:00:00 PM"

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

    With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.ListObjects.Add(xlSrcRange, Range("$A$1:$G$" & 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, False, False

MyApt.Save





cell.Offset(0, 1).Value = "yes"

'Clear the AppBody rows up to the header
With Worksheets("AppBody")
.ListObjects("Table1").Unlist
.Range("A2:G" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

End If
End If

Next


'Delete AppBody sheet
Application.DisplayAlerts = False
Worksheets("AppBody").Delete
Application.DisplayAlerts = True

'Return to the appointment content sheet
mWs.Activate
'Clear 'yes' from column H
Range("H2:H" & i + 1).ClearContents

End Sub

'Does the worksheet exists
Function WorksheetExists(WSName) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
    End Function

 

[jag108]

Hi,

I modified my email code from here, which created a single mail for Outlook for rows with same email addresses.

Email with rows included in VBA

Hi folks, Bit of a VBA novice. Would be grateful if anyone can help with the code. I have data like the below and I want to send one email to each unique email address in column E, copying in the address in column B. In the body of the email, I want to have all the rows for that country like...

www.mrexcel.com

Roughly
The macro looks for and deletes an AppBody sheet.
The macro copies the column header to AppBody
The macro loops down column G to get the first date.
Copies the row to AppBody
A second nested loop checks for the same date
Any rows with matching date are copied
A yes is appended to H on all copied rows so they are not processed again
AppBody content is auto fitted otherwise the date is just #######

The AppBody content is turned into Table 1 so it can be copied to the appointment using Word

The table is then unlisted and the content cleared

The Outlook appointment Code isn't something I use so you'll likely need to sort out the dates for that from cell.value and any other content missed.
I've just used something used before to check the table is copying based on next due date.
Happy to look if you post back.

If you don't want to send the whole rows take a shot at adjusting the code

Sub Make_App()


Dim AppBody As Range

Set mWs = Worksheets("Sheet2")

'If AppBody sheet already exists then delete it
If WorksheetExists("AppBody") Then
Application.DisplayAlerts = False
Worksheets("AppBody").Delete
Application.DisplayAlerts = True
End If

'Add a sheet to copy all same person rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "AppBody"

'Copy the header
   mWs.Rows(1).Copy Destination:=Worksheets("AppBody").Range("A1")

'Return to the appointment content sheet
   mWs.Activate

'Set due next date as range for first loop to run down
    Set rng = Range(Range("G2"), Range("G" & Rows.Count).End(xlUp))

'Get a row count to clear column H at the end
  i = rng.Rows.Count


For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 1).Value = "yes" Then

'Get the row number
    cRow = cell.Row

'Copy the row to the first empty row in the AppBody sheet
mWs.Range("A" & cRow, "G" & cRow).Copy Destination:=Sheets("AppBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)


'Second loop checks the dates of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the AppBody sheet
    For Each dwn In rng.Offset(cRow - 1, 0)

    dRow = dwn.Row
    If dwn.Value = cell.Value Then

    dwn.Offset(0, 1).Value = "yes"

'Create additional table row for each extra row found
    mWs.Range("A" & dRow, "G" & dRow).Copy Destination:=Sheets("AppBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

    End If

    Next

'Autofit the copied rows on the new sheet, otherwise they'll be copied to the mail with defaults widths, heights
With Worksheets("AppBody")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set AppBody = .Range(.Cells(1, 1), .Cells(lRow, 7))
.Range("A1:G2").Columns.AutoFit
    End With


'Construct appointment
Set myOutlook = CreateObject("Outlook.Application")
'Set ID = "Identity"
Set MyApt = myOutlook.createitem(1)
MyApt.Subject = "Subject"
MyApt.Start = " 6:00:00 PM"
    MyApt.End = " 7:00:00 PM"

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

    With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.ListObjects.Add(xlSrcRange, Range("$A$1:$G$" & 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, False, False

MyApt.Save





cell.Offset(0, 1).Value = "yes"

'Clear the AppBody rows up to the header
With Worksheets("AppBody")
.ListObjects("Table1").Unlist
.Range("A2:G" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

End If
End If

Next


'Delete AppBody sheet
Application.DisplayAlerts = False
Worksheets("AppBody").Delete
Application.DisplayAlerts = True

'Return to the appointment content sheet
mWs.Activate
'Clear 'yes' from column H
Range("H2:H" & i + 1).ClearContents

End Sub

'Does the worksheet exists
Function WorksheetExists(WSName) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
    End Function

Awesome, thanks Dave, just what I was after.

 

[daverunt]

Glad to help.

 

[daverunt]

Just noticed:
Dim AppBody As Range ??????
Previous email code reference.

AppBody is a worksheet now.

 

[jag108]

Just noticed:
Dim AppBody As Range ??????
Previous email code reference.

AppBody is a worksheet now.

Thanks, figured that one out. Just adding some extra bits and pieces now like attendees, location etc...
The code you gave would have taken me a month of Sundays to figure out, so thanks very much.