data manipulation

M

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.
 
Sort by date Sort by votes
Scott thank you so much for coming back to me. Much appreciated.

I have run your procedure and I get a message "No date for the key meeting". The customer numbers e.g. '51' or '9999' or '888' or '7777' did not get highlighted in bold.

In addition on sheet1 (master data) in col E - Meet date 1 (the first of the 12 meet date columns) the first 31 entries get deleted each time i run the procedure.

In my sheet1 I have the following (the key meeting date is in Col D:

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

Also, for each customer name / customer no. there may not, as yet, be 12 meeting dates for each. I populated sheet1 to ensure ALL customer names / customer no. had a meeting date (31-dec-99) but I still got the message "No date for the key meeting".

For each month sheet the 'customer no.' get populated, via your the procedure, from col E (we changed this last time around (?)) This all works fine.

I trust the above assists?

thanks again
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
If you have 3 as the key meeting but only have two meetings then you do not have a valid key meeting. If you still want the rest of the code to run then I have changed the code to skip that key meeting but still have a message box to let you know you have an invalid key meeting. You can comment out the line or remove it if you do not want the notification.

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


'jan
For y = 2 To lr
    keydate = ws.Cells(y, 3).Offset(, ws.Cells(y, 3))
    If keydate = "" Then
        MsgBox ("No date for the key meeting") ' comment out or remove if you do not want the message box
        GoTo invalidkeydate      
        
    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
    
invalidkeydate:
Next y


End Sub
 
Upvote 0
Hi Scott I have run the amended procedure you very kindly provided. Unfortunately, I get an error message;

Run time error 13:
Type mismatch.

In running the debug option this appears to be in the 'bold key meeting ' step as all meeting dates appear to be populated ok.

Any thoughts and thanks again for all your efforts.​
 
Upvote 0
What is the actual line is highlighted when you debug?
 
Upvote 0
What column is the Key meeting date in on your master data sheet? I think I may have used the wrong column.
 
Upvote 0
column 4 holds the key meeting date.

My master sheet is called "sheet1" at present

The column is headed by:

Key meet date

Each row contains a number between 1-12 which correspond to the months of the year.
 
Upvote 0
Change the 3 to a 4
Code: 
[FONT=Arial][SIZE=2][COLOR=#000000]keydate = ws.Cells(y, 4).Offset(, ws.Cells(y, 4)[/COLOR][/SIZE][/FONT]
 
Upvote 0
Hi Scott, changing the procedure as requested has overcome the error message of;

Run time error 13:
Type mismatch.

The procedure now runs but in the “to bold key meeting” step of the procedure I get a message;
"No date for the key meeting". - This message I receive for only 7 times (I have run several times) – I reply ok and then the following message;

Run time error 13:
Type mismatch.

In reviewing each month’s meetings none of the key meeting numbers are in BOLD.

In addition, the procedure deletes data in my master data sheet – called sheet1 but only Col E which is the first set of meeting dates but only the first 31 rows of 350 (?)

To clarify my master data layout sheet called “sheet1”;

no
Customer number
Customer name
key meet date
Meet date 1
Meet date 2
Meet date 3
Meet date 4
Meet date 5
etc
1
A51
Customer1
10
28-Nov-17
26-Dec-17
23-Jan-18
27-Feb-18
27-Mar-18
2
A160
Customer2
1
21-Nov-17
16-Jan-18
20-Feb-18
20-Mar-18
17-Apr-18
3
A214
Customer3
1
21-Nov-17
16-Jan-18
20-Mar-18
18-Sep-18
20-Nov-18
4
A276
Customer4
12
07-Dec-17
01-Feb-18
01-Mar-18
05-Apr-18
03-May-18
5
A433
Customer5
10
20-Nov-17
18-Dec-17
19-Feb-18
19-Mar-18
16-Apr-18
6
A453
Customer6
6
09-Nov-17
26-Apr-18
14-Jun-18
13-Sep-18
08-Nov-18
7
A650
Customer7
10
14-Nov-17
12-Dec-17
09-Jan-18
13-Feb-18
13-Mar-18
8
A697
Customer8
5
15-Nov-17
20-Dec-17
21-Feb-18
21-Mar-18
18-Apr-18
9
A1000
Customer9
1
16-Nov-17
18-Jan-18
15-Feb-18
15-Mar-18
20-Sep-18
10
A1024
Customer10
10
27-Dec-17
24-Jan-18
28-Feb-18
28-Mar-18
11
etc








<tbody>
</tbody>

To clarify my output for each month’s sheets called Nov17 or Jan18 or Jan19 etc. is;

Day of Month
Day of week
No in Month
01/01/2018
1
Mon
02/01/2018
2
Tue
03/01/2018
3
Wed
A6230, A6484
04/01/2018
4
Thu
A2342, A4220, A8913
05/01/2018
5
Fri
A8527
06/01/2018
6
Sat
A4456, A4738, A5217, A5388, A6718, A6804
07/01/2018
7
Sun
08/01/2018
8
Mon
A1312, A1977, A7143, A7975, A8005
09/01/2018
9
Tue
A650, A8871

<tbody>
</tbody>

Scott, I trust the above is helpful to you. Many thanks as always for your time in trying to resolve my issue.
 
Upvote 0
Change this line
Code: 
Set rng = ws.Range(ws.Cells(2, 4), ws.Cells(lr, lc))

To
Code: 
Set rng = ws.Range(ws.Cells(2, 5), ws.Cells(lr, lc))

When I run the code with the above change with sheet1 like this
Excel 2010
A
B
C
D
E
F
G
H
I
J
1
no
Customer number
Customer name
key meet date
Meet date 1
Meet date 2
Meet date 3
Meet date 4
Meet date 5
Meet date 6
2
1
A51
Customer1
10
28-Nov-17
26-Dec-17
23-Jan-18
27-Feb-18
27-Mar-18
3
2
A160
Customer2
1
21-Nov-17
16-Jan-18
20-Feb-18
20-Mar-18
17-Apr-18
4
3
A214
Customer3
1
21-Nov-17
16-Jan-18
20-Mar-18
18-Sep-18
20-Nov-18
5
4
A276
Customer4
12
7-Dec-17
1-Feb-18
1-Mar-18
5-Apr-18
3-May-18
6
5
A433
Customer5
10
20-Nov-17
18-Dec-17
19-Feb-18
19-Mar-18
16-Apr-18
7
6
A453
Customer6
6
9-Nov-17
26-Apr-18
14-Jun-18
13-Sep-18
8-Nov-18
12/7/2018
8
7
A650
Customer7
10
14-Nov-17
12-Dec-17
9-Jan-18
13-Feb-18
13-Mar-18
9
8
A697
Customer8
5
15-Nov-17
20-Dec-17
21-Feb-18
21-Mar-18
18-Apr-18
10
9
A1000
Customer9
1
16-Nov-17
18-Jan-18
15-Feb-18
15-Mar-18
20-Sep-18
11
10
A1024
Customer10
10
27-Dec-17
24-Jan-18
28-Feb-18
28-Mar-18

<tbody>
</tbody>
Sheet1​
and the months sheets like this
Excel 2010
A
B
C
D
1
Day of month
day of week
no in month
2
11/1/2017
1
Wed
3
11/2/2017
2
Thu
4
11/3/2017
3
Fri
5
11/4/2017
4
Sat
6
11/5/2017
5
Sun
7
11/6/2017
6
Mon
8
11/7/2017
7
Tue
9
11/8/2017
8
Wed
10
11/9/2017
9
Thu
A453
11
11/10/2017
10
Fri
12
11/11/2017
11
Sat
13
11/12/2017
12
Sun
14
11/13/2017
13
Mon
15
11/14/2017
14
Tue
A650
16
11/15/2017
15
Wed
A697
17
11/16/2017
16
Thu
A1000
18
11/17/2017
17
Fri
19
11/18/2017
18
Sat
20
11/19/2017
19
Sun
21
11/20/2017
20
Mon
A433
22
11/21/2017
21
Tue
A160, A214
23
11/22/2017
22
Wed
24
11/23/2017
23
Thu
25
11/24/2017
24
Fri
26
11/25/2017
25
Sat
27
11/26/2017
26
Sun
28
11/27/2017
27
Mon
29
11/28/2017
28
Tue
A51
30
11/29/2017
29
Wed
31
11/30/2017
30
Thu

<tbody>
</tbody>
Nov17​

I get the bolding and nothing deleted on Sheet1.

What line is highlighted if you debug?

this part deletes column D on the monthly but ignores Sheet1
Code: 
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

Could you post a copy of the code you are running.


The complete code

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, 5), 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
        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

'jan
For y = 2 To lr
    keydate = ws.Cells(y, 4).Offset(, ws.Cells(y, 4))
    If keydate = "" Then
        MsgBox ("No date for the key meeting") ' comment out or remove if you do not want the message box
        GoTo invalidkeydate
        
    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
    
invalidkeydate:
Next y
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Easy formula i think
Replies
3
Views
55
Joe4
Joe4
C
  • Solved
Dates in Table
2
Replies
10
Views
372
Alex Blakenburg
A
M
  • Solved
How to count certain month from a column
Replies
3
Views
121
Joe4
Joe4
S
  • Solved
Count the number of days between two dates that are in 2024
2
Replies
15
Views
316
Fluff
Fluff
M
  • Question
suggest excel formula to calculate cumulative interest on no of days etc ......
Replies
1
Views
242
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,140
Messages
6,123,267
Members
449,093
Latest member
Vincent Khandagale

Share this page

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