If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.

Create dynamic table in apointment body

Thread starter jag108
Start date Jul 13, 2020

jag108

Active Member

Jul 13, 2020

#1

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

3

Server2

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

4

Server3

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

5

Server4

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

6

Server5

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

7

Server6

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

8

Server7

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

9

Server8

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

10

Server9

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

11

Server10

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

12

Server11

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

13

Server12

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

14

Server13

APG-DevTest-ThirdSun-2amTo4am

Third Sun

7

3

15

Server14

APG-Prod-FirstSun-2amTo4am

First Sun

7

1

16

Server15

APG-Prod-FirstSun-2amTo4am

First Sun

7

1

17

Server16

APG-Prod-FirstSun-2amTo4am

First Sun

7

1

18

Server17

APG-Prod-FirstSun-2amTo4am

First Sun

7

1

19

Server18

APG-Prod-FirstSun-2amTo4am

First Sun

7

1

20

Server19

APG-Prod-FirstWed-2amTo3am

First Wed

3

1

21

Server20

APG-Prod-FirstWed-2amTo3am

First Wed

3

1

22

Server21

APG-Prod-FirstWed-2amTo3am

First Wed

3

1

23

Server22

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

24

Server23

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

25

Server24

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

26

Server25

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

27

Server26

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

28

Server27

APG-Prod-FourthSun-0amTo2am

Fourth Sun

7

4

29

Server28

APG-Prod-FourthSun-2amTo4am

Fourth Sun

7

4

30

Server29

APG-Prod-FourthSun-2amTo4am

Fourth Sun

7

4

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?

Excel Facts

How to change case of text in Excel?

Click here to reveal answer

Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

Sort by date Sort by votes

D

daverunt

Well-known Member

Jul 14, 2020

#2

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

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

Last edited: Jul 14, 2020

Upvote 0

jag108

Active Member

Jul 14, 2020

#3

daverunt said:
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

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.

Upvote 0

D

daverunt

Well-known Member

Jul 15, 2020

#4

Glad to help.

Upvote 0

D

daverunt

Well-known Member

Jul 15, 2020

#5

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

AppBody is a worksheet now.

Upvote 0

jag108

Active Member

Jul 15, 2020

#6

daverunt said:
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.

Upvote 0

You must log in or register to reply here.

Similar threads

Question

Formula to find first sunday in month, greater than current date

2

Replies: 10

Views: 5K

Jul 9, 2020

Peter_SSs

S

Question

Date and Time Formulas

2 3 4

Replies: 34

Views: 2K

Mar 17, 2023

awoohaw

V

Question

Returning Randomly Selected Value from Table based on Criteria

Replies: 4

Views: 781

Jul 27, 2022

Viau1337

V

P

Question

help on creating dynamic pivot table and chart.

Replies: 0

Views: 577

Nov 22, 2009

priscillakim

P

Share:

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Forum statistics

Threads: 1,223,639

Messages: 6,173,499

Members: 452,517

Latest member: SoerenB

Share this page

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Top