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