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
 

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

acw

MrExcel MVP
Joined
Feb 13, 2004
Messages
4,814
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
 

wavemehello

Board Regular
Joined
Jan 24, 2006
Messages
221
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")
 

acw

MrExcel MVP
Joined
Feb 13, 2004
Messages
4,814
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
 

SydneyGeek

MrExcel MVP
Joined
Aug 5, 2003
Messages
12,251

ADVERTISEMENT

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
 

wavemehello

Board Regular
Joined
Jan 24, 2006
Messages
221
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?
 

SydneyGeek

MrExcel MVP
Joined
Aug 5, 2003
Messages
12,251

ADVERTISEMENT

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
 

acw

MrExcel MVP
Joined
Feb 13, 2004
Messages
4,814
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
 

wavemehello

Board Regular
Joined
Jan 24, 2006
Messages
221
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."
 

acw

MrExcel MVP
Joined
Feb 13, 2004
Messages
4,814
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
 

Watch MrExcel Video

Forum statistics

Threads
1,108,491
Messages
5,523,255
Members
409,506
Latest member
reneekeane

This Week's Hot Topics

Top