Forum Discussion
VBA issue - Need code to match data elements between worksheets and a worksheet name and move/post
- Jul 28, 2022
Deleted
Thanks. I have attached the workbook with a command button that executes a macro. I have added lots of comments to the macro.
The workbook is now a macro-enabled workbook (.xlsm), so you'll have to allow macros when you open it.
If that doesn't work, here is the code:
Sub PostHours() Dim wI As Worksheet Dim e As String Dim wE As Worksheet Dim dS As String Dim rS As Range Dim dE As String Dim rE As Range Dim r As Range Dim rH As Range Dim h As Double Dim d As String Dim p As String Dim rD As Range Dim rP As Range ' Time input sheet Set wI = Worksheets("Time Input") ' Employee e = wI.Range("B1").Value ' Employee sheet Set wE = Worksheets(e) ' Start date of segment dS = wI.Range("B5").Value ' Cell with start date on employee sheet Set rS = wE.Range("A:A").Find(What:=dS, LookAt:=xlWhole) ' end date of segment dE = wI.Range("Q5").Value ' Cell with end date on employrr sheet Set rE = wE.Range("A:A").Find(What:=dE, LookAt:=xlWhole) ' Clear hours in date range wE.Range(rS, rE).Offset(0, 1).Resize(, 10).ClearContents ' Range with hours On Error Resume Next Set rH = wI.Range("B7:Q9").SpecialCells(xlCellTypeConstants) On Error GoTo 0 ' If range is empty, we're done If rH Is Nothing Then Exit Sub ' Loop For Each r In rH ' Hours h = r.Value ' Date d = wI.Cells(5, r.Column).Value ' Date header cell Set rD = wE.Range("A:A").Find(What:=d, LookAt:=xlWhole) ' Project p = wI.Cells(r.Row, 1).Value ' Project header cell Set rP = wE.Range("1:1").Find(What:=p, LookAt:=xlWhole) ' Fill cell with hours wE.Cells(rD.Row, rP.Column).Value = h Next r End Sub
Deleted
Could you attach a sample workbook (without sensitive data), or if that is not possible, make it available through OneDrive, Google Drive, Dropbox or similar? Thanks in advance.
Thanks Hans!! Here is a Google Drive link.
- HansVogelaarJul 28, 2022MVP
Deleted
I get "Access Denied". You'll need to share the file.
- AnonymousJul 28, 2022Sorry Hans, please try again!
- HansVogelaarJul 28, 2022MVP
Deleted
Thanks. I have attached the workbook with a command button that executes a macro. I have added lots of comments to the macro.
The workbook is now a macro-enabled workbook (.xlsm), so you'll have to allow macros when you open it.
If that doesn't work, here is the code:
Sub PostHours() Dim wI As Worksheet Dim e As String Dim wE As Worksheet Dim dS As String Dim rS As Range Dim dE As String Dim rE As Range Dim r As Range Dim rH As Range Dim h As Double Dim d As String Dim p As String Dim rD As Range Dim rP As Range ' Time input sheet Set wI = Worksheets("Time Input") ' Employee e = wI.Range("B1").Value ' Employee sheet Set wE = Worksheets(e) ' Start date of segment dS = wI.Range("B5").Value ' Cell with start date on employee sheet Set rS = wE.Range("A:A").Find(What:=dS, LookAt:=xlWhole) ' end date of segment dE = wI.Range("Q5").Value ' Cell with end date on employrr sheet Set rE = wE.Range("A:A").Find(What:=dE, LookAt:=xlWhole) ' Clear hours in date range wE.Range(rS, rE).Offset(0, 1).Resize(, 10).ClearContents ' Range with hours On Error Resume Next Set rH = wI.Range("B7:Q9").SpecialCells(xlCellTypeConstants) On Error GoTo 0 ' If range is empty, we're done If rH Is Nothing Then Exit Sub ' Loop For Each r In rH ' Hours h = r.Value ' Date d = wI.Cells(5, r.Column).Value ' Date header cell Set rD = wE.Range("A:A").Find(What:=d, LookAt:=xlWhole) ' Project p = wI.Cells(r.Row, 1).Value ' Project header cell Set rP = wE.Range("1:1").Find(What:=p, LookAt:=xlWhole) ' Fill cell with hours wE.Cells(rD.Row, rP.Column).Value = h Next r End Sub