A simple project update VBA that is not match the projects

F

fogarasia

New Member
Joined
Feb 6, 2023
Messages
18
Office Version
  1. 365
Platform
  1. Windows
Hi there!

I am struggling with this project, to have working it.
I have the first sheet where I fill in the hours and choose the project and date. And I have here the update button, which is a macro-related. When this is pressed, then on the next sheet all these data are aligned, and the hours are copied to this sheet right position and deleted from the first one. Some extra check are in the code.
Project 202/01/2024PersonWorking Hours
Name 1
Name 2
Name 3
Name 4
Name 5
Name 6
Select projectSelect dateFill hours


Second sheet:
Innovation project loadings_macro.xlsm
ABCDEFGHIJKLMNOP
1Grand total hours/projectColumn1Column2Column3Column4Column5Column6Column7Column8Column9Column10Column11Column12Column13Column14Column15
201/01/202402/01/202403/01/202404/01/202405/01/202406/01/202407/01/202408/01/202409/01/202410/01/202411/01/202412/01/202413/01/202414/01/2024
4
50Project 100000000000000
60Name 1
70Name 2
80Name 3
90Name 4
100Name 5
110Name 6
120Project 200000000000000
130Name 1
140Name 2
150Name 3
160Name 4
170Name 5
180Name 6
190Project 300000000000000
200Name 1
210Name 2
220Name 3
230Name 4
240Name 5
250Name 6
260Project 400000000000000
270Name 1
280Name 2
290Name 3
300Name 4
310Name 5
320Name 6
330Project 500000000000000
340Name 1
350Name 2
360Name 3
370Name 4
380Name 5
390Name 6
400Project 600000000000000
410Name 1
420Name 2
430Name 3
440Name 4
450Name 5
460Name 6
470Project 700000000000000
480Name 1
490Name 2
500Name 3
510Name 4
520Name 5
530Name 6
540Project 800000000000000
550Name 1
560Name 2
570Name 3
580Name 4
590Name 5
600Name 6
610Project 900000000000000
620Name 1
630Name 2
640Name 3
650Name 4
660Name 5
670Name 6
680Project 1000000000000000
690Name 1
700Name 2
710Name 3
720Name 4
730Name 5
740Name 6
750Project 1100000000000000
760Name 1
770Name 2
780Name 3
790Name 4
800Name 5
810Name 6
820Project 1200000000000000
830Name 1
840Name 2
850Name 3
860Name 4
870Name 5
880Name 6
890Project 1300000000000000
900Name 1
910Name 2
920Name 3
930Name 4
940Name 5
950Name 6
960Project 1400000000000000
970Name 1
980Name 2
Sheet1
Cell Formulas
RangeFormula
C5:P5,C96:P96,C89:P89,C82:P82,C75:P75,C68:P68,C61:P61,C54:P54,C47:P47,C40:P40,C33:P33,C26:P26,C19:P19,C12:P12C5=SUBTOTAL(9,C6:C11)
A5:A98A5=SUM(C5:ND5)
Cells with Data Validation
CellAllowCriteria
B5List=Sources!$B$2:$B$27
B89List=Sources!$B$2:$B$27
B82List=Sources!$B$2:$B$27
B75List=Sources!$B$2:$B$27
B68List=Sources!$B$2:$B$27
B61List=Sources!$B$2:$B$27
B54List=Sources!$B$2:$B$27
B47List=Sources!$B$2:$B$27
B40List=Sources!$B$2:$B$27
B33List=Sources!$B$2:$B$27
B26List=Sources!$B$2:$B$27
B19List=Sources!$B$2:$B$27
B12List=Sources!$B$2:$B$27
B96List=Sources!$B$2:$B$27


And the code:

VBA Code: 
Sub UpdateHours()
    Dim wsData As Worksheet
    Dim wsSheet1 As Worksheet
    Dim projectName As String
    Dim selectedDate As Date
    Dim personNames As Range
    Dim workingHours As Range
    Dim lastRowData As Long
    Dim i As Long
    Dim foundProject As Range
    Dim foundDate As Range
    Dim foundPerson As Range
    Dim selectedProjectCell As Range
    Dim overwriteData As VbMsgBoxResult
    Dim projectRow As Long
    Dim dateColumn As Long

    ' Set references to sheets
    Set wsData = ThisWorkbook.Sheets("Data")
    Set wsSheet1 = ThisWorkbook.Sheets("Sheet1")

    ' Get user input
    projectName = Trim(wsData.Range("A1").Value)

    ' Check if date is a valid date
    On Error Resume Next
    selectedDate = CDate(wsData.Range("B1").Value)
    On Error GoTo 0

    ' Find the last row in Data sheet
    lastRowData = wsData.Cells(wsData.Rows.Count, "C").End(xlUp).Row

    ' Find the project row in Sheet1
    Set foundProject = wsSheet1.Columns("B").Find(What:=projectName, LookIn:=xlValues, LookAt:=xlWhole)

    ' Check if project is found
    If foundProject Is Nothing Then
        MsgBox "Project not found in Sheet1!", vbExclamation
        Exit Sub
    End If

    ' Find the date column in Sheet1
    Set foundDate = wsSheet1.Rows(2).Find(What:=selectedDate, LookIn:=xlValues, LookAt:=xlWhole)

    ' Check if date is found
    If foundDate Is Nothing Then
        MsgBox "Selected date not found in Sheet1! Selected Date: " & selectedDate, vbExclamation
        Exit Sub
    End If

    ' Check if the selected project cell in Sheet1 contains data
    Set selectedProjectCell = wsSheet1.Cells(foundProject.Row, foundDate.Column)
    If Not IsEmpty(selectedProjectCell.Value) Then
        ' Prompt to confirm overwriting data
        overwriteData = MsgBox("The selected project contains data. Would you like to overwrite?", vbQuestion + vbYesNo, "Confirmation")

        If overwriteData = vbNo Then
            Exit Sub ' User chose not to overwrite, exit sub
        End If
    End If

    ' Get the project row in Sheet1
    projectRow = foundProject.Row

    ' Get the date column in Sheet1
    dateColumn = foundDate.Column

    ' Copy data to Sheet1
    Set personNames = wsData.Range("C2:C" & lastRowData)
    Set workingHours = wsData.Range("D2:D" & lastRowData)

    ' Copy numbers to Sheet1
    For i = 1 To personNames.Rows.Count
        If personNames.Cells(i, 1).Value <> "" Then
            ' Find the person in Sheet1 for the selected project
            Set foundPerson = wsSheet1.Columns("B").Find(What:=personNames.Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)

            ' Check if person is found
            If foundPerson Is Nothing Then
                MsgBox "Person not found in Sheet1 for Project: " & projectName & " - Person: " & personNames.Cells(i, 1).Value, vbExclamation
                Exit Sub
            End If

            ' Copy working hours to Sheet1
            wsSheet1.Cells(foundPerson.Row, dateColumn).Value = IIf(workingHours.Cells(i, 1).Value = "", 0, workingHours.Cells(i, 1).Value)
        End If
    Next i

    ' Clear only working hours in Data sheet
    wsData.Range("D2:D" & lastRowData).ClearContents
End Sub


But somehow I can not guess how to make it to align with the projects itself.
Somebody help me please to fix this issue.
Thanks!
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
without the After part every search will be starting at the top of column B and stoping at the first instance of personNames witch will be in project 1
Rich (BB code): 
Set foundPerson = wsSheet1.Columns("B").Find(What:=personNames.Cells(i, 1).Value, After:=foundProject, LookIn:=xlValues, LookAt:=xlWhole)
 
Upvote 0
Solution
NoSparks said:
without the After part every search will be starting at the top of column B and stoping at the first instance of personNames witch will be in project 1
Rich (BB code): 
Set foundPerson = wsSheet1.Columns("B").Find(What:=personNames.Cells(i, 1).Value, After:=foundProject, LookIn:=xlValues, LookAt:=xlWhole)
Click to expand...
This was perfectly working, so I ma really thank you!
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
523
VanGirl
V
D
  • Question Question
Can't get MailMerge to work through VBA
Replies
0
Views
279
DetroitJimBurke
D
Drrellik
  • Solved
VBA to complete Index/Match with 2 criteria
2
Replies
10
Views
422
Alex Blakenburg
A
A
  • Solved
VBA Help!
Replies
2
Views
406
AusNewb
A
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
813
Agnarr
Agnarr

Forum statistics

Threads
1,223,886
Messages
6,175,195
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top