Press button to assign the reason provided and count

[Aussiebear]

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.

[Paul_Hossler]

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)





Option Explicit


Private Sub Workbook_Open()
Init
End Sub




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




Option Explicit


Public wsStore As Worksheet, wsInput As Worksheet


Sub Init()

....
....
....

[Aussiebear]

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.

[Paul_Hossler]

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

3082630827

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



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
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)

[Aussiebear]

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?

[Paul_Hossler]

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?


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

[Aussiebear]

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?

[georgiboy]

For the parts lookup on this version - maybe:

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

[Paul_Hossler]

See if this floats your boat:thumb




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

[Aussiebear]

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