Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ThisWorkbook.NoEvents = True
If Intersect(Target, Range("K7")) Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
CalendarFrm.Show
Dim rowCount As Long, srcWS As Worksheet, Rng As Range, lastRow As Long, x As Long, y As Long, z As Long
Dim att As Long, take As Long, discuss As Long, dir As Long, com As Long, dsi As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
att = Range("A:A").Find("MEETING ATTENDEES:").Row
take = Range("A:A").Find("TAKE AWAY / GUIDANCE:").Row
discuss = Range("A:A").Find("DISCUSSION:").Row
dir = Range("A:A").Find("DIRECTORATE HIGHLIGHTS:").Row
com = Range("A:A").Find("Communications and Major Events").Row
dsi = Range("A:A").Find("Directorate of Systems Integration (DSI)").Row
If Range("A" & dsi + 1) <> "" Then Rows(dsi + 1).ClearContents
If Range("A" & com + 1) <> "" Then Rows(com + 1).ClearContents
If Range("A" & discuss + 1) <> "" Then Rows(discuss + 1 & ":" & dir - 2).EntireRow.Delete
If Range("A" & take + 1) <> "" Then Rows(take + 1 & ":" & discuss - 2).EntireRow.Delete
If Range("A" & att + 1) <> "" Then Rows(att + 1 & ":" & take - 2).EntireRow.Delete
Range("M3:N" & lastRow).ClearContents
Range("D9").ClearContents
Range("K3").Select
x = 1
y = att + 1
z = att
On Error Resume Next
Set srcWS = Sheets(Format(Target, "mm-dd-yyyy"))
On Error GoTo 0
If Not srcWS Is Nothing Then
Range("D9") = Range("K7")
With srcWS.Cells(2, 1)
.AutoFilter Field:=3, Criteria1:="<>"
End With
rowCount = [subtotal(103,A:A)] - 2
srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
Range("M3").PasteSpecial xlPasteValues
srcWS.Range("C3", srcWS.Range("C" & srcWS.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
Range("N3").PasteSpecial xlPasteValues
lastRow = Range("M" & Rows.Count).End(xlUp).Row
For Each Rng In Range("M3:M" & lastRow)
Rng.Copy
Cells(y, x).Insert
With Cells(y, x)
.Value = ChrW(&H25A0) & " " & Cells(y, x)
.WrapText = False
End With
y = y + 1
If y > z + WorksheetFunction.RoundUp(rowCount / 3, 0) Then
y = 16
x = x + 3
End If
Next Rng
take = Range("A:A").Find("TAKE AWAY / GUIDANCE:").Row
With srcWS.Cells(2, 1)
.AutoFilter Field:=4, Criteria1:="<>"
End With
lastRow = srcWS.Range("D" & srcWS.Rows.Count).End(xlUp).Row
x = 1
For Each Rng In srcWS.Range("D3:D" & lastRow).SpecialCells(xlCellTypeVisible)
Dim val As String
val = Rng.Value
Cells(take + 1, x).Insert
With Cells(take + 1, x)
.Value = ChrW(&H25A0) & " " & val
.Font.Bold = False
End With
take = take + 1
Next Rng
srcWS.Range("C2").AutoFilter
If srcWS.Range("F7") <> "" Then
discuss = Range("A:A").Find("DISCUSSION:").Row
val = srcWS.Range("F7").Value
Cells(discuss + 1, x).Insert
With Cells(discuss + 1, x)
.Value = ChrW(&H25A0) & " " & val
.WrapText = False
.Font.Bold = False
End With
End If
If srcWS.Range("F8") <> "" Then
discuss = discuss + 1
val = srcWS.Range("F8").Value
Cells(discuss, x).Insert
With Cells(discuss, x)
.Value = ChrW(&H25A0) & " " & val
.WrapText = False
.Font.Bold = False
End With
End If
srcWS.Range("C2").AutoFilter
If srcWS.Range("F12") <> "" Then
com = Range("A:A").Find("Communications and Major Events").Row
val = srcWS.Range("F12").Value
With Cells(com + 1, x)
.Value = ChrW(&H25A0) & " " & val
.WrapText = False
.Font.Bold = False
End With
End If
If srcWS.Range("F10") <> "" Then
dsi = Range("A:A").Find("Directorate of Systems Integration (DSI)").Row
val = srcWS.Range("F10").Value
With Cells(dsi + 1, x)
.Value = ChrW(&H25A0) & " " & val
.WrapText = False
.Font.Bold = False
End With
End If
Else
MsgBox ("A worksheet with the date " & Target & " does not exist. Please select a different date.")
Target.ClearContents
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = False
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = False
Range("K3").Select
End If
If Range("A16") <> "" Then
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = True
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = True
Else
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = False
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = False
End If
ThisWorkbook.NoEvents = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub