had1015
10-17-2019, 09:10 AM
Hi,
I posted this question at the following location and have not gotten response:
https://www.excelforum.com/excel-programming-vba-macros/1293258-copy-employee-data-between-sheets.html
I have several hundred project task sheets (indicated as sheet names like the attached “1000 A 1” in the attached workbook) that I’m looping through in my workbook that takes many hours of manual input. I would like to a macro to transfer employee information from the “MR” worksheet to the project Task worksheets. I’ve included a sample workbook to clarify my problem. I am trying to transfer hours worked in weekly increments based on the end period date which are located on row 21 on each project task sheet. On the project sheet I set up weekly columns to transfer employee information (ID, Last Name, First and Middle Initials and hours worked) for each project.
1. Cell “C4” on each project task sheet is the same as the sheet name which is also the project number.
2. I need to find that same project number located in on the PR sheet column A.
3. When it's identified, I need to match that project number in the PR sheet column A to the MR sheet column A, the end period PR sheet column K to the MR sheet column B and LC code PR sheet column P to the MR sheet column E.
4. Whenever those three matches are made I need to copy the matched column A adjacent cell values (Employee Number, LC Code, Employee Name and Initials) from the MR sheet columns D, E, F, and G to the project task sheet starting with cell A25 through D25.
5. Then copy the hours worked from the adjacent cell column H to the task sheet appropriate adjacent cell for that respective end period date. Any additional hours worked for this same project by another employee will be transferred directly beneath the first employee information and hours.
You can see the before and after project task sheets in the attached file.
Any assistance you provide is greatly appreciated.
I've tried to use some code below but it's not working for me:
Sub CopyEmployeeData()
Dim Firstrow As Long
Dim Lastrow As Long
Dim PRLastrow As Long
Dim MRLastrow As Long
Dim Lrow As Long
Dim PRLrow As Long
Dim MRLrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
Lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
PRLastrow = Sheets("PR").Cells(.Rows.Count, "A").End(xlUp).Row
MRLastrow = Sheets("MR").Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = Lastrow To Firstrow Step -1
For PRLrow = PRLastrow To Firstrow Step -1
For MRLrow = MRLastrow To Firstrow Step -1
With .Cells(Lrow, "C")
If Not IsError(.Value) Then
If .Value = Sheets("PR").Cells(Lrow, "A").Value Then
If Sheets("PR").Cells(PRLrow, "A").Value = Sheets("MR").Cells(MRLrow, "A").Value And _
Sheets("PR").Cells(PRLrow, "K").Value = Sheets("MR").Cells(MRLrow, "B").Value And _
Sheets("PR").Cells(PRLrow, "P").Value = Sheets("MR").Cells(MRLrow, "E").Value Then
.Offset(18, -2).Value = Sheets("MR").Cells(MRLrow, "A").Value
End If
End If
End If
End With
Next MRLrow
Next PRLrow
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
I posted this question at the following location and have not gotten response:
https://www.excelforum.com/excel-programming-vba-macros/1293258-copy-employee-data-between-sheets.html
I have several hundred project task sheets (indicated as sheet names like the attached “1000 A 1” in the attached workbook) that I’m looping through in my workbook that takes many hours of manual input. I would like to a macro to transfer employee information from the “MR” worksheet to the project Task worksheets. I’ve included a sample workbook to clarify my problem. I am trying to transfer hours worked in weekly increments based on the end period date which are located on row 21 on each project task sheet. On the project sheet I set up weekly columns to transfer employee information (ID, Last Name, First and Middle Initials and hours worked) for each project.
1. Cell “C4” on each project task sheet is the same as the sheet name which is also the project number.
2. I need to find that same project number located in on the PR sheet column A.
3. When it's identified, I need to match that project number in the PR sheet column A to the MR sheet column A, the end period PR sheet column K to the MR sheet column B and LC code PR sheet column P to the MR sheet column E.
4. Whenever those three matches are made I need to copy the matched column A adjacent cell values (Employee Number, LC Code, Employee Name and Initials) from the MR sheet columns D, E, F, and G to the project task sheet starting with cell A25 through D25.
5. Then copy the hours worked from the adjacent cell column H to the task sheet appropriate adjacent cell for that respective end period date. Any additional hours worked for this same project by another employee will be transferred directly beneath the first employee information and hours.
You can see the before and after project task sheets in the attached file.
Any assistance you provide is greatly appreciated.
I've tried to use some code below but it's not working for me:
Sub CopyEmployeeData()
Dim Firstrow As Long
Dim Lastrow As Long
Dim PRLastrow As Long
Dim MRLastrow As Long
Dim Lrow As Long
Dim PRLrow As Long
Dim MRLrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
Lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
PRLastrow = Sheets("PR").Cells(.Rows.Count, "A").End(xlUp).Row
MRLastrow = Sheets("MR").Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = Lastrow To Firstrow Step -1
For PRLrow = PRLastrow To Firstrow Step -1
For MRLrow = MRLastrow To Firstrow Step -1
With .Cells(Lrow, "C")
If Not IsError(.Value) Then
If .Value = Sheets("PR").Cells(Lrow, "A").Value Then
If Sheets("PR").Cells(PRLrow, "A").Value = Sheets("MR").Cells(MRLrow, "A").Value And _
Sheets("PR").Cells(PRLrow, "K").Value = Sheets("MR").Cells(MRLrow, "B").Value And _
Sheets("PR").Cells(PRLrow, "P").Value = Sheets("MR").Cells(MRLrow, "E").Value Then
.Offset(18, -2).Value = Sheets("MR").Cells(MRLrow, "A").Value
End If
End If
End If
End With
Next MRLrow
Next PRLrow
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub