Display data stored in another worksheet-CodePudding

Is there a better way to do this (a way that works?) So I am trying to create a small database where payroll admins can store punch data and hours data as the week goes on and submit the data to an output sheet where Human Resources (that's me) can upload the data for payroll. This is my first time trying to build something VBA myself rather than just copy pasting and editing values from the internet. I have a worksheet (Input_form) that acts like a user form for inputting all relevant data, and the idea is to submit all data that a user writes in into the appropriate line on my roster sheet (DoNotDelete_Source), but first I want to show any data that's already stored there (such as hours input previously, so they do not overwrite valid data or spent time inputting data they already have). To do this they would insert the person number (ID unique to person, but not to the row, so then there is a dependent dropdown with Assignment number which is unique to a row), select the Assignment Number, and click the "Find Person's Data" button. This button is an activex control with the following code:

   Sub FindPersonsData()
Dim PN As Variant
Dim AN As Variant
Dim ws2 As Worksheet
Dim ws1 As Worksheet
Dim RowCalc As Range
Dim Source As Range

Set ws1 = Sheets("Input_Form")
Set ws2 = Sheets("DoNotDelete_Source")
PN = ws1.Range("Person_Num").Value
AN = ws1.Range("Assignment_Num").Value
Set Source = ws2.Range("Source")


Application.ScreenUpdating = False
For Each RowCalc In Source
''>>For every row in the source range
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Saturday" And ws2.Cells(1, 7) Like "Regular Hours" Then
''>>Check If Col A has the same person number, Col B has the same assignment number, Col E has the same WeekDay, and Col G has the same Element Name, and if it does then
        ws1.Range("SatRegHr").Value = ws2.Cells(1, 8).Value
''>>Display the "regular hours" cell value for the row in correct cell in Input_Form
    Else
        ws1.Range("SatRegHr").Value = 0
''>>If there is no data for that day/element name, there are - hours for that day so display 0
    End If
''>>move onto the next element name or day

''>>>>>>>>>>(Here is what I'm worried about: is this saying just to check if the first row matches all of that then set the hours value, but if not the to move on and not FIND THE ROW THAT MATCHES?)
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Saturday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("SatOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("SatOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Sunday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("SunRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("SunRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Sunday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("SunOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("SunOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Monday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("MonRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("MonRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Monday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("MonOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("MonOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Tuesday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("TueRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("TueRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Tuesday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("TueOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("TueOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Wednesday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("WedRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("WedRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Wednesday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("WedOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("WedOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Thursday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("ThuRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("ThuRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Thursday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("ThuOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("ThuOTHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Friday" And ws2.Cells(1, 7) Like "Regular Hours" Then
    ws1.Range("FriRegHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("FriRegHr").Value = 0
End If
If ws2.Cells(1, 1).Value Like PN And ws2.Cells(1, 2).Value Like AN And ws2.Cells(1, 5).Value Like "Friday" And ws2.Cells(1, 7) Like "Overtime" Then
    ws1.Range("FriOTHr").Value = ws2.Cells(1, 8).Value
Else
    ws1.Range("FriOTHr").Value = 0
End If




Next RowCalc
Application.ScreenUpdating = True


End Sub

Which is on its way to working but:

This takes about two minutes per submission and I am making this to be a user friendly option for non-Excel savvy payroll admins so I don't want them to be scared by the Not Responding screen.

Also, and more importantly, The result is all zeros, not the actual data- not sure why none are matching, is it the AND - LIKE statements? I also have about 25 more sections that I would create If statements for, which I am sure will not help the speed... thanks! Right now I am Only trying to display data from one sheet based on a provided value (person number) upon the click of the "Show Person's Data" button- like an index match but with VBA and with 50 different indexes all based on different match criteria (days of week, element names). Later on I will need to do the opposite... (Store the data).

Any ideas are appreciated! Thank you so much!

Edit: Here is the Input Form Sheet: https://imgur.com/a/WIwJteT

and an example of what the Roster Sheet looks like: https://imgur.com/a/Y420sEG

CodePudding user response：

You are reading cell-by-cell way too many times (although your posted code actually only ever reads from the first row... Performance is optimal when you hit the sheet as little as possible.

Compiled but not tested:

Sub FindPersonsData()
    Dim PN As Variant
    Dim AN As Variant
    Dim ws2 As Worksheet
    Dim ws1 As Worksheet
    Dim RowCalc As Range
    Dim Source As Range, arrDays, d, d3, rowDay, hrs
    
    Set ws1 = Sheets("Input_Form")
    Set ws2 = Sheets("DoNotDelete_Source")
    PN = ws1.Range("Person_Num").Value
    AN = ws1.Range("Assignment_Num").Value
    Set Source = ws2.Range("Source")
    
    arrDays = Array("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
    'set all cells to default zero hrs
    For Each d In arrDays
        d3 = Left(d, 3) 'short day name
        ws1.Range(d3 & "RegHr").Value = 0
        ws1.Range(d3 & "OTHr").Value = 0
    Next d
    
    'loop data and find any existing data
    For Each RowCalc In Source.Rows 'must specify `Rows` here, otherwise it will be `Cells`
        'no point in reading a bunch of cells if the first value match fails...
        If RowCalc.Cells(1).Value = PN Then
            If RowCalc.Cells(2).Value = AN Then
                rowDay = RowCalc.Cells(5).Value
                For Each d In arrDays
                    If rowDay = d Then
                        d3 = Left(d, 3)
                        hrs = RowCalc.Cells(8).Value
                        Select Case RowCalc.Cells(7).Value
                            Case "Regular Hours": ws1.Range(d3 & "RegHr").Value = hrs
                            Case "Overtime": ws1.Range(d3 & "OTHr").Value = hrs
                        End Select
                    End If
                Next d
            End If
        End If
    Next

End Sub