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
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, 4), ws.Cells(lr, lc))
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
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
'jan
For y = 2 To lr
keydate = ws.Cells(y, 3).Offset(, ws.Cells(y, 3))
If keydte = "" Then
MsgBox ("No date for the key meeting")
Exit Sub
End If
keyyear = Year(keydate)
keymonth = Month(keydate)
cusnumber = ws.Cells(y, 2)
cuslen = Len(ws.Cells(y, 2))
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
Next y
End Sub
