Staff birthday list for next month

wavemehello

Board Regular
Joined
Jan 24, 2006
Messages
221
Hi there,

I have a worksheet. Column(A) has Department name, Column(B) has staffname, Column(C) has Position, Column(E) has Dateofbirth, Column(P) =month(dateofbirth). There are about 400 records.

I have to find the staff birthdays 1 month prior so that I can distribute the birthdays of staff in coming month to the department heads.

I wrote the following macro for this. And it works fine running well for the last 3 months. This is how it works. It checks the coming month with the month of the Dateof birth of each record and if found copies the Departmentname and Staffname in birthday worksheet. Again it checks the Position and Dateofbirth and if found copies it them to the birthday worksheet for the corresponding rows.

I am posting it because,
1) code may be beneficial to anybody.
2) I am not satisfied with the coding, I believe that any of you professional can reduce the code drastically and that is where I need your help.
3) when the macro is run, the worksheet flickers coz it does to and fro in two worksheets.

You suggestions and help in this regard will be highlighy appreciated.



Sub birthday()
Dim lastrow As Integer
Dim b As Integer
Dim namess As Integer

'Worksheets("Birthday").Columns(1).Delete
'Worksheets("Birthday").Columns(2).Delete
namess = Sheets.Count
b = 2

lastrow = Range("A800").End(xlUp).Row
Worksheets(namess).Activate

For i = 1 To lastrow
If Cells(i, 16) = Month(Now()) + 1 Then

ActiveSheet.Range(Cells(i, 1), Cells(i, 2)).Copy
Worksheets("Birthday").Select
Worksheets("Birthday").Range(Cells(b, 1), Cells(b, 2)).Select
Worksheets("Birthday").Paste
b = b + 1
Worksheets(namess).Activate
End If
Next i
i = 0
b = 0
namess = 0
namessss = Sheets.Count
b = 2
lastrow = Range("A800").End(xlUp).Row
Worksheets(namessss).Activate
For i = 1 To lastrow
If Cells(i, 16) = Month(Now()) + 1 Then
ActiveSheet.Range(Cells(i, 4), Cells(i, 5)).Copy
Worksheets("Birthday").Select
Worksheets("Birthday").Range(Cells(b, 3), Cells(b, 4)).Select
Worksheets("Birthday").Paste
b = b + 1
Worksheets(namessss).Activate
End If
Next i
Worksheets("birthday").Activate
Columns(3).Delete
End Sub
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Hi

I think I have this right. I gather that sheets(sheets.count) is the last sheet in the workbook and contains the raw data.

You don't need the column with the calculation of the month - it is done from the birthdate.

Code:
Sub bbb()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Birthday")
  Sheets(Sheets.Count).Select
  For Each ce In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Month(ce.Offset(0, 4)) = Month(Now()) + 1 Then
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      OutSH.Cells(outrow, 1).Resize(1, 3).Value = Range(ce, ce.Offset(0, 2)).Value
      OutSH.Cells(outrow, 4).Value = ce.Offset(0, 4).Value
    End If
  Next ce
End Sub


HTH

Tony
 
Upvote 0
Hi Tony/any gentleman,
Thank you

I would appreciate if you can make out time to explain what the code lines between for and next do?


Thankx




("It needs the whole village to raise a child")
 
Upvote 0
Hi

Changed it slightly to cover the current month being December, and added some comments.

Code:
Sub bbb()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Birthday")
  Sheets(Sheets.Count).Select
'determine the range to be examined, starting in A2 and dynamically finding the last
'row in column A.  Cycle through each entry in that range by using the variable ce
  For Each ce In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
'establish the next month value
    TestMonth = Month(Now()) + 1
    If TestMonth = 13 Then TestMonth = 1
'test the month of the birthdate in column E to see if it is the current month + 1
    If Month(ce.Offset(0, 4)) = TestMonth Then
'variable to hold the next blank row on the sheet Birthday
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'copy across the columns A:C values
      OutSH.Cells(outrow, 1).Resize(1, 3).Value = Range(ce, ce.Offset(0, 2)).Value
'copy across column E values
      OutSH.Cells(outrow, 4).Value = ce.Offset(0, 4).Value
    End If
  Next ce
End Sub


Tony
 
Upvote 0
Another option, instead of looping, is to filter the data and copy all matching data in one go.
This code relies on you having the target monthNo in S2, with S1 having the same heading as the corresponding data in the list. For example, P1 is Month(DOB). In S1, put Month(DOB). In S2, put this formula:
Code:
=IF(MONTH(TODAY())=12,1,MONTH(TODAY())+1)
Code is as follows:
Code:
Sub FilterBirthdays()
' Filter for birthdays coming up next month.
' Filter Month goes in H2
' List is copied to Birthdays, then sorted by Dept and Name
    
    Dim Rw As Long
    Rw = Range("A65536").End(xlUp).Row
    'clear destination list
    Sheets("Birthdays").Cells.ClearContents
    'show all data, incase filters still applied
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    'filter and copy new data
    With Range("A1:P" & Rw)
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
            Range("S1:S2"), Unique:=False
        .Select
    End With
    Selection.SpecialCells(xlCellTypeVisible).Copy
    Sheets("Birthdays").Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    'sort
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    Columns("C:P").ClearContents
End Sub
Denis
 
Upvote 0
Just to mention that my original data is in CURRENTMONTH (which is on the extreme Right hand side in the sheet tab and BIRTHDAY sheet is on the extreme left sheet) and the copied records should go in the blank worksheet Birthday.

I created a macro of your codes, then selecting CURRENTMONTH, I ran the kbrd shortcut for the macro but nothing is coming up in birthday sheet.

Where did I go wrong?
 
Upvote 0
Generally, if you paste code into a module you won't have a keyboard shortcut. Try Alt+F8, and double-clicking the macro name.

Denis
 
Upvote 0
Hi

1) Which code - or is it both
2) If your source data is in sheet CURRENTMONTH then in my code, change the line
sheets(sheets.count).select
to
sheets("CURRENTMONTH").select

Tony
 
Upvote 0
Tony,
I am not getting any extracted records in the birthday sheet. I created a simple form for CURRENTMONTH worksheet and put a simple command button there and then pasted your code inside it. And then called the form using userform1.show in Thisworkbook. so when I open the file, the form comes and I click the command button but the birthday worksheet is still empty.

What wrong went in my part?

Sydney: thank you! will try ur codes after tony's help!


"It takes the whole village to raise a child."
 
Upvote 0
Hi

I did the same thing except I ran the code to open the form and it worked.

userform1 had a commandbutton (commandbutton1) which has the code

Code:
Private Sub CommandButton1_Click()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Birthday")
  Sheets("CURRENTMONTH").Select
'determine the range to be examined, starting in A2 and dynamically finding the last
'row in column A.  Cycle through each entry in that range by using the variable ce
  For Each ce In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
'establish the next month value
    TestMonth = Month(Now()) + 1
    If TestMonth = 13 Then TestMonth = 1
'test the month of the birthdate in column E to see if it is the current month + 1
    If Month(ce.Offset(0, 4)) = TestMonth Then
'variable to hold the next blank row on the sheet Birthday
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'copy across the columns A:C values
      OutSH.Cells(outrow, 1).Resize(1, 3).Value = Range(ce, ce.Offset(0, 2)).Value
'copy across column E values
      OutSH.Cells(outrow, 4).Value = ce.Offset(0, 4).Value
    End If
  Next ce

End Sub


Tony
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,245
Members
448,555
Latest member
RobertJones1986

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