[SOLVED:] Press button to assign the reason provided and count

1 Attachment(s)

Press button to assign the reason provided and count

Alas our poor industrious boys are in trouble again. The Accountant (Paul) noticed after reviewing last years financials that on some days the two enterprising young lads did not earn any income. Suspicious that maybe one or both were not at work that day, he set up a new form to determine if and why they were absent from work. I need a way to enable our industrious lads to account for their absence, hence the WhereYaBin questionnaire. I need a way to select the person submitting the reason from a DV cell Sheet1 J9, and the reason Sheet1 K9, also a DV cell. Because I am working on a Mac I can't use an active X button.

So any code needs to be assigned to the Shape "Submit Reason" after both a Name and a reason has been completed. The results need to recorded on sheet3 F3:I3 and down for each new occurrence. The count variable (Cell I3) needs to count only the number of times a particular reason has occurred and a Date on which the reason was submitted. The date is important to stop Zack (who is known to be somewhat mischievous), from sitting there tapping away throwing his partner under the bus. So only one submitted reason per day if possible.

1 Attachment(s)

Some things to consider

The 'dual' lookup (PN and Desc) didn't really work. Changed formulas to always use PN, and Desc to use PN and PN to get Desc

I added a Lads absence feature based on my guesses

Made use of WB and WS events

Made the .Names dynamic so you can just add / delete

Rearranged some stuff and created some new .Names (sorry)

Code:

Option Explicit Private Sub Workbook_Open() Init End Sub

Code:

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Range, rLad As Range Dim iLad As Long Set r = Target.Cells(1, 1) Application.EnableEvents = False Select Case r.Address Case "$D$8" Range("$D$9").Value = Application.Evaluate("=XLOOKUP(D8,PartNum,PartDesc,"""",0,1)") Case "$D$9" Range("$D$8").Value = Application.Evaluate("=XLOOKUP(D9,PartDesc,PartNum,"""",0,1)") Case "$H$9", "$J$9" If Len(Range("H9").Value) > 0 And Len(Range("J9").Value) > 0 Then iLad = Application.Evaluate("=XMATCH(H9,Lads,0,1)") Set rLad = [Lads].Cells(iLad, 1) Set rLad = rLad.Offset(0, 1) If CLng(rLad.Value) = CLng(Date) Then Call MsgBox("Sorry, you only get one", vbCritical + vbOKOnly, "Taking Off") Range("H9").Value = vbNullString Range("J9").Value = vbNullString Else rLad.Value = DateSerial(Year(Now), Month(Now), Day(Now)) Range("H9").Value = vbNullString Range("J9").Value = vbNullString End If End If End Select Application.EnableEvents = True End Sub

Code:

Option Explicit Public wsStore As Worksheet, wsInput As Worksheet Sub Init() .... .... ....

Sorry Paul but a couple of issues with your version. Firstly in the VBE I notice the you have Sheet2 (Storeman Sheet), and Sheet3 (Sheet2). Will that cause an issue down the track?

Also, the count for the number of times an excuse has been used does not increase.

2 Attachment(s)

Quote:

Firstly in the VBE I notice the you have Sheet2 (Storeman Sheet), and Sheet3 (Sheet2). Will that cause an issue down the track?

Attachment 30826 Attachment 30827

Not seeing Sheet3 or Sheet2 anywhere in the code. "Sheet2" in "Sheet2 (Storeman Sheet)" is the .CodeName, and "Sheet1" in "Sheet1 (Sheet1)" is the .Name

Quote:

Also, the count for the number of times an excuse has been used does not increase.

I didn't know if you wanted the count by Lad or just totaled since I could interpert

Quote:

So only one submitted reason per day if possible.

several different ways

a. #times used by any Lad any Date - #reasons x 2 -- keep going forever, what you have in now
b. #times used by each Lad any Date - #reasons x # Lads x 2 -- keep going forever, add column for each Lad
c. #times used by each Lad by each Date - #reasons x # Lads x #days -- keep going forever, add Date column and column for each Lad

d. #times used by any Lad today - #reasons x 2 (reset each day)
e. #times used by each Lad today - #reasons x #Lads x 2 (reset each day)

Oops. My apologies to you, as a third sheet had been created from this end. Might just go Lad name, Date and reason and reason count, if possible please?

1 Attachment(s)

Quote:

Might just go Lad name, Date and reason and reason count, if possible please?

Sure -- Excel can do ANYTHING :yes

It sounds like a log file, and would probably look like this

IS this what you want?

Attachment 30828

On 5/21 Paul had 6 absences - 3 for lady tourist, 1 for spider, and 2 for mother in law

My dummy data might be unrealistic, but I was just thinking on the data structure

Hmmm.... Would it be possible for the count to go the other way? As in 1 for the first time of use and 3rd for when the Grandmother apparently died for the third time?

For the parts lookup on this version - maybe:

Code:

Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("B8:D9")) Is Nothing Then If Target.Address = "$D$8" Then Range("D8:D11").Value = Evaluate("TOCOL(XLOOKUP(" & Target.Address & ",'Storeman''s Sheet'!A:A,'Storeman''s Sheet'!A:D,"""",0),3)") Else Range("D8:D11").Value = Evaluate("TOCOL(XLOOKUP(" & Target.Address & ",'Storeman''s Sheet'!B:B,'Storeman''s Sheet'!A:D,"""",0),3)") End If End If Application.EnableEvents = True End Sub

1 Attachment(s)

See if this floats your boat:thumb

Code:

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Range Dim iLad As Long Dim sLad As String, sReason As String Set r = Target.Cells(1, 1) Application.EnableEvents = False Select Case r.Address Case "$D$8" Range("$D$9").Value = Application.Evaluate("=XLOOKUP(D8,PartNum,PartDesc,"""",0,1)") Case "$D$9" Range("$D$8").Value = Application.Evaluate("=XLOOKUP(D9,PartDesc,PartNum,"""",0,1)") Case "$H$9", "$J$9" sLad = Range("H9").Value sReason = Range("J9").Value 'only place I like GoTo's since IMHO is makes the flow easier to follow If Len(sLad) = 0 Then GoTo NiceExit If Len(sReason) = 0 Then GoTo NiceExit With wsStats 'empty list, only headers so add as row 2 If .Cells(1, 1).CurrentRegion.Rows.Count = 1 Then .Cells(2, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now)) .Cells(2, 2).Value = sLad .Cells(2, 3).Value = sReason .Cells(2, 4).Value = 1 GoTo AllDone End If 'first one of the day, any Lad so add at bottom iLad = .Cells(1, 1).CurrentRegion.Rows.Count If CLng(.Cells(iLad, 1).Value) < CLng(DateSerial(Year(Now), Month(Now), Day(Now))) Then .Cells(iLad + 1, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now)) .Cells(iLad + 1, 2).Value = sLad .Cells(iLad + 1, 3).Value = sReason .Cells(iLad + 1, 4).Value = 1 GoTo AllDone End If 'start at bottom go up looking for Lad and Reason on Today iLad = .Cells(1, 1).CurrentRegion.Rows.Count Do While .Cells(iLad, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now)) If .Cells(iLad, 2).Value = sLad And .Cells(iLad, 3).Value = sReason Then .Cells(iLad, 4).Value = .Cells(iLad, 4).Value + 1 GoTo AllDone Else iLad = iLad - 1 If iLad = 1 Then Exit Do End If Loop 'if we got this far, we did not find matching Date, Lad and Reason so add at bottom 'yes, I know it'sthe same as 'first one of day, but I like the flow iLad = .Cells(1, 1).CurrentRegion.Rows.Count .Cells(iLad + 1, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now)) .Cells(iLad + 1, 2).Value = sLad .Cells(iLad + 1, 3).Value = sReason .Cells(iLad + 1, 4).Value = 1 GoTo AllDone End With AllDone: 'clear Lad and Reson Range("H9").Value = vbNullString Range("J9").Value = vbNullString NiceExit: End Select Application.EnableEvents = True End Sub

Floats... I've had to lengthen the anchor chain. Thank you for your contribution.