Sub meetings()
Dim ws As Worksheet
Dim janws As Worksheet
Dim febws As Worksheet
Dim marws As Worksheet
Dim aprws As Worksheet
Dim mayws As Worksheet
Dim junws As Worksheet
Dim julws As Worksheet
Dim augws As Worksheet
Dim sepws As Worksheet
Dim octws As Worksheet
Dim novws As Worksheet
Dim decws As Worksheet
Dim lr As Long
Dim lc As Long
Dim rng As Range
Dim cell As Range
Dim w As Worksheet
Dim wsq As Worksheet
Dim mws As Worksheet
Set ws = Sheets("Sheet1")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = ws.Range(ws.Cells(2, 5), ws.Cells(lr, lc))
Application.ScreenUpdating = False
For Each w In ActiveWorkbook.Worksheets
If w.Name <> "Sheet1" Then
w.Range("D2.D32").ClearContents 'clear columns in monthly sheets so new data can be entered
w.Range("D2.D32").ClearFormats 'clear columns in monthly sheets of formatting
End If
Next w
'for Jan
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 1 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Jan" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Jen" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Jan" & myyear).Cells(x, 1) Then
Sheets("Jan" & myyear).Cells(x, "D") = Sheets("Jan" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Jan" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Jan" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Jan" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Feb
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 2 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Feb" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Feb" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Feb" & myyear).Cells(x, 1) Then
Sheets("Feb" & myyear).Cells(x, "D") = Sheets("Feb" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Feb" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Feb" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Feb" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Mar
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 3 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Mar" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Mar" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Mar" & myyear).Cells(x, 1) Then
Sheets("Mar" & myyear).Cells(x, "D") = Sheets("Mar" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Mar" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Mar" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Mar" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Apr
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 4 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Apr" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Apr" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Apr" & myyear).Cells(x, 1) Then
Sheets("Apr" & myyear).Cells(x, "D") = Sheets("Apr" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Apr" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Apr" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Apr" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for May
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 5 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("May" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "May" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("May" & myyear).Cells(x, 1) Then
Sheets("May" & myyear).Cells(x, "D") = Sheets("May" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("May" & myyear).Cells(x, "D"), 1) = "," Then Sheets("May" & myyear).Cells(x, "D") = Application.Substitute(Sheets("May" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Jun
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 6 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Jun" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Jun" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Jun" & myyear).Cells(x, 1) Then
Sheets("Jun" & myyear).Cells(x, "D") = Sheets("Jun" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Jun" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Jun" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Jun" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Jul
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 7 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Jul" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Jul" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Jul" & myyear).Cells(x, 1) Then
Sheets("Jul" & myyear).Cells(x, "D") = Sheets("Jul" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Jul" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Jul" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Jul" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Aug
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 8 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Aug" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Aug" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Aug" & myyear).Cells(x, 1) Then
Sheets("Aug" & myyear).Cells(x, "D") = Sheets("Aug" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Aug" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Aug" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Aug" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Sept
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 9 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Sept" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Sept" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Sept" & myyear).Cells(x, 1) Then
Sheets("Sept" & myyear).Cells(x, "D") = Sheets("Sept" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Sept" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Sept" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Sept" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Oct
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 10 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Oct" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Oct" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Oct" & myyear).Cells(x, 1) Then
Sheets("Oct" & myyear).Cells(x, "D") = Sheets("Oct" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Oct" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Oct" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Oct" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Nov
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 11 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Nov" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Nov" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Nov" & myyear).Cells(x, 1) Then
Sheets("Nov" & myyear).Cells(x, "D") = Sheets("Nov" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Nov" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Nov" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Nov" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'for Dec
For x = 2 To 32
For Each cell In rng
If cell <> "" And Month(cell) = 12 Then
myyear = Right(Year(cell), 2)
Set wsq = Nothing
On Error Resume Next
Set wsq = Sheets("Dec" & myyear)
On Error GoTo 0
If wsq Is Nothing Then
MsgBox ("Sheet " & "Dec" & myyear & " does not exist please create sheet")
Exit Sub
End If
If cell = Sheets("Dec" & myyear).Cells(x, 1) Then
Sheets("Dec" & myyear).Cells(x, "D") = Sheets("Dec" & myyear).Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)
If Left(Sheets("Dec" & myyear).Cells(x, "D"), 1) = "," Then Sheets("Dec" & myyear).Cells(x, "D") = Application.Substitute(Sheets("Dec" & myyear).Cells(x, "D"), ", ", "")
End If
End If
Next cell
Next x
'to bold key meeting
For y = 2 To lr
cusnumber = ws.Cells(y, 2)
cuslen = Len(ws.Cells(y, 2))
lkc = ws.Cells(y, Columns.Count).End(xlToLeft).Column
For m = 5 To lkc
keymonth = ws.Cells(y, 4)
If keymonth = Month(ws.Cells(y, m)) Then
keydate = ws.Cells(y, m)
keyyear = Year(ws.Cells(y, m))
End If
If keydate = "" Then GoTo invalidkeydate
Select Case keymonth
Case Is = 1
keymonth = "Jan"
Case Is = 2
keymonth = "Feb"
Case Is = 3
keymonth = "Mar"
Case Is = 4
keymonth = "Apr"
Case Is = 5
keymonth = "May"
Case Is = 6
keymonth = "Jun"
Case Is = 7
keymonth = "Jul"
Case Is = 8
keymonth = "Aug"
Case Is = 9
keymonth = "Sept"
Case Is = 10
keymonth = "Oct"
Case Is = 11
keymonth = "Nov"
Case Is = 12
keymonth = "Dec"
End Select
mrow = Application.Match(CLng(keydate), Sheets(keymonth & Right(keyyear, 2)).Range("A1:A32"), 0)
kstart = InStr(Sheets(keymonth & Right(keyyear, 2)).Cells(mrow, 4), cusnumber)
Sheets(keymonth & Right(keyyear, 2)).Cells(mrow, 4).Characters(kstart, cuslen).Font.Bold = True
keydate = ""
keymonth = ""
invalidkeydate:
Next m
Next y
Application.ScreenUpdating = True
End Sub
