data manipulation

Manexcel

Board Regular
Joined
Dec 28, 2015
Messages
127
Office Version
  1. 365
Platform
  1. Windows
I have a dataset of around 300 customer names. Each name is unique. Each name also has a unique number (can be 2 or 3 or 4 digits) e.g. customer1 51, customer2 9999, customer3 888, customer 4 7777 etc.


I have a series of meeting dates with each customer for 2018 e.g. 23-jan-18 and 27-Feb-18 and 27-Mar-18 etc. Could be 12 meetings per annum or 3 or 4 or 5 or any number in between

For each meeting there is a documented key meeting date (month number) e.g. 1 to 12. For this meeting I would like to have highlighted in BOLD.

An example dataset is below:

Customer name / customer no./ Key meet date / Meet date 1 / Meet date 2... / Meet date 12 etc
customer 1 / 51 / 1 / 01-jan-18 / 02-feb-18 / 03-mar-18 etc
customer 2 / 9999 / 3 / 02-jan-18 / 02-feb-18 / 04-mar-18 / 01-oct-18 / 01-dec-18
customer 3 / 888 / 2 / 03-jan-18 / 03-feb-18 / 01-mar-18
customer 4 / 7777 / 3 / 04-mar-18 / 01-sep-18

etc

My goal would be to have a monthly overview (1 month per sheet), by actual day of each month, for each of these meetings that occur on any given date / day. But only the numbers against each day in each month AND for each key meeting number to be in BOLD

An example of what my requested output is below:

For each month of the year...

Jan

1 51,
2 9999,
3 888,
4
31

Feb

1
2 51,9999,
3 888,
4
28

Mar

1 888
2
3 51,
4 9999, 7777,
31

etc.

Is it possible to create the above output via formula(s)?
I thank you in anticipation and for your consideration and time.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
You wanted formulas but try this code. Not sure if or how to bold part of a string in VBA so this does not bold the key meet date.

Code:
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 rng As Range
Dim cell As Range
Set ws = Sheets("Sheet1")
Set janws = Sheets("Jan")
Set febws = Sheets("Feb")
Set marws = Sheets("Mar")
Set marws = Sheets("Apr")
Set marws = Sheets("May")
Set marws = Sheets("Jun")
Set marws = Sheets("Jul")
Set marws = Sheets("Aug")
Set marws = Sheets("Sept")
Set marws = Sheets("Oct")
Set marws = Sheets("Nov")
Set marws = Sheets("Dec")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("D2:R" & lr)
'for Jan
lastday = janws.Cells(Rows.Count, 1).End(xlUp).Row
janws.Range("B2:B" & lastday).ClearContents
For x = 2 To lastday
For Each cell In rng
    If Month(cell) = 1 And Day(cell) = janws.Cells(x, 1) Then
        janws.Cells(x, 2) = janws.Cells(x, 2) & ", " & ws.Cells(cell.Row, 2)
        If Left(janws.Cells(x, 2), 1) = "," Then janws.Cells(x, 2) = Application.Substitute(janws.Cells(x, 2), ", ", "")
    End If
Next cell
Next x
'for feb
lastday = febws.Cells(Rows.Count, 1).End(xlUp).Row
febws.Range("B2:B" & lastday).ClearContents
For x = 2 To lastday
For Each cell In rng
    If Month(cell) = 2 And Day(cell) = febws.Cells(x, 1) Then
        febws.Cells(x, 2) = febws.Cells(x, 2) & ", " & ws.Cells(cell.Row, 2)
        If Left(febws.Cells(x, 2), 1) = "," Then febws.Cells(x, 2) = Application.Substitute(febws.Cells(x, 2), ", ", "'")
    End If
Next cell
Next x
'for mar
lastday = marws.Cells(Rows.Count, 1).End(xlUp).Row
marws.Range("B2:B" & lastday).ClearContents
For x = 2 To lastday
For Each cell In rng
    If Month(cell) = 3 And Day(cell) = marws.Cells(x, 1) Then
        marws.Cells(x, 2) = marws.Cells(x, 2) & ", " & ws.Cells(cell.Row, 2)
        If Left(marws.Cells(x, 2), 1) = "," Then marws.Cells(x, 2) = Application.Substitute(marws.Cells(x, 2), ", ", "'")
    End If
Next cell
Next x
'for apr
lastday = aprws.Cells(Rows.Count, 1).End(xlUp).Row
aprws.Range("B2:B" & lastday).ClearContents
For x = 2 To lastday
For Each cell In rng
    If Month(cell) = 3 And Day(cell) = aprws.Cells(x, 1) Then
        aprws.Cells(x, 2) = aprws.Cells(x, 2) & ", " & ws.Cells(cell.Row, 2)
        If Left(aprws.Cells(x, 2), 1) = "," Then aprws.Cells(x, 2) = Application.Substitute(aprws.Cells(x, 2), ", ", "'")
    End If
Next cell
Next x

'repeat for remaining months. You will need to update the worksheet and the month number for each section

End Sub
 
Upvote 0
Scott, the code you have very kindly provided appears to be populating each months worksheets. I am only looking at Jan-Apr first and then will enhance your code for remaining months.

However, the code appears to be putting in meeting dates on Sundays and I know I do not have meeting dates on a Sunday in my dataset.

Also, if I wanted to populate the output from col D onwards in each month instead of Col B what do I need to change in the procedure?

Many thanks for all your time and efforts.
 
Upvote 0
The code only looks at the month and the day in the dates (1st, 2nd, 3rd...) and sees if that matched the number in the month sheet. Are all the dates in the same year?


The 2 is the column number A is 1 B is 2 and so on. Change all the column numbers for each month to the column you want.
Code:
[COLOR=#333333] janws.Cells(x, [/COLOR][COLOR=#ff0000]2[/COLOR][COLOR=#333333]) = janws.Cells(x, [/COLOR][COLOR=#ff0000]2[/COLOR][COLOR=#333333]) & ", " & ws.Cells(cell.Row, 2)[/COLOR]

If you prefer you can put the column letter in quotes like below
Code:
[COLOR=#333333] janws.Cells(x, "D") = janws.Cells(x, "D") & ", " & ws.Cells(cell.Row, 2)[/COLOR]
 
Upvote 0
scott, thank you for your response. In the dataset I have there is a rolling 12 month period. So there will be 2018 and 2019 dates. I just really want 2018 meeting dates.

As for the columns I will change.

Many thanks for your help and patience.
 
Upvote 0
Do you have the year on the months sheets? We will need to test the whole date. Are you OK with putting the date down the column like this
ABCD
1Jan
21/1/201851
31/2/20189999
41/3/2018888
51/4/2018
61/5/2018
71/6/2018
81/7/2018
91/8/2018
101/9/2018
111/10/2018
121/11/2018
131/12/2018
141/13/2018
151/14/2018
161/15/2018
171/16/2018
181/17/2018
191/18/2018
201/19/2018
211/20/2018
221/21/2018
231/22/2018
241/23/2018
251/24/2018
261/25/2018
271/26/2018
281/27/2018
291/28/2018
301/29/2018
311/30/2018
321/31/2018

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><tbody>
</tbody>
Sheet2
 
Upvote 0
Try this code. The sheet names should be month and year like Jan18, Feb19

Code:
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


'repeat for remaining months. You will need to update the worksheet and the month number for each section


End Sub
 
Upvote 0
Scott once gain thank you. Working great now that I put the dates in each sheet as you requested.

Too date, the source meeting dates, on sheet1, have commenced in Col 4 to Col 14. Each column is headed by meet date 1 to meet date 10.

However, can you advise what i need to change in the procedure if I wanted the source meeting dates to commence in column , say 16 and end in say col 25?

Many thanks for all your time, efforts and patience.
 
Upvote 0
This sets the range to from D2 (cells(2,4)) to last row(based on column A) and last column based on the headers in row one
Code:
Set rng = ws.Range(ws.Cells(2, 4), ws.Cells(lr, lc))

Change the 4 to the column you want to start in .
 
Upvote 0
I figured out how to bold the key meetings. Try this code out

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,553
Messages
6,114,279
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top