Staff birthday list for next month

[wavemehello]

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

 

[wavemehello]

I got a runtime error with yellow highlight at debug, at line
If Month(ce.Offset(0, 4)) = TestMonth Then

 

[wavemehello]

Hi Tony!!

It worked this time. Just that my DOB was not in Column E Thankx a lot!! :wink:










("It takes a whole village to raise a child")