Simple 'Dispensing' program

[peteprp]

Hi all,
I want to create a very simple dispensing program. I have an excel listing of medications - see below. I want to be able to do a 'wildcard' search for a particular medication and then be able to enter the quantity dispensed. The quantity dispensed should be added to the cumulative total dispensed for that particular medication. At the end of the day or week, I'd like to be able to see & download/copy the total amount dispensed for each medication.

[TABLE="width: 404"]
<tbody>[TR]
[TD]DRUG NAME[/TD]
[TD]UNITS[/TD]
[/TR]
[TR]
[TD]Aluminium Chlorohydrate Cream 20%[/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Aluminium sulphate Solution 20% Spray 25mL[/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Amethocaine Mimum 0.5% 20's[/TD]
[TD]Per Minum[/TD]
[/TR]
[TR]
[TD]Aminophylline Amps 250mg/10ml[/TD]
[TD]Per Amp[/TD]
[/TR]
[TR]
[TD]Amiodarone Inj 150mg/3mL[/TD]
[TD]Per Amp[/TD]
[/TR]
[TR]
[TD]Amlodipine Tabs 10mg[/TD]
[TD]Per Tab[/TD]
[/TR]
[TR]
[TD]Amoxycillin 100mg Drps[/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Amoxycillin 400mg, clavulanate 57mg Syr [/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Amoxycillin 875mg, clavulanate 125mg Tabs [/TD]
[TD]Per Tab[/TD]
[/TR]
[TR]
[TD]Amoxycillin Amps 1gm[/TD]
[TD]Per Vial[/TD]
[/TR]
[TR]
[TD]Amoxycillin Caps 250mg[/TD]
[TD]Per Caps[/TD]
[/TR]
[TR]
[TD]Amoxycillin Caps 500mg [/TD]
[TD]Per Caps[/TD]
[/TR]
[TR]
[TD]Amoxycillin Syrup SF 125mg/5ml [/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Amoxycillin Syrup SF 250mg/5ml [/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Antazoline/ Naphazoline Eye Drops [/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Aqueous Cream 100g cream[/TD]
[TD]Ea[/TD]
[/TR]
[TR]
[TD]Artesunate Inj 60mg[/TD]
[TD]Per Vial[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 317"]
<tbody>[TR]
[TD]Search Drug Name:[/TD]
[/TR]
[TR]
[TD]For example, type in amox 25 c[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 587"]
<tbody>[TR]
[TD="colspan: 2"]Then show result below together with Units column & add[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]the number of capsules dispensed in the column alongside[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Enter Number Dispensed[/TD]
[/TR]
[TR]
[TD]Amoxycillin Caps 250mg[/TD]
[TD]Per Caps[/TD]
[TD]

5​

[/TD]
[/TR]
</tbody>[/TABLE]

If anyone can help, I would really appreciate it. Is it possible to do this without using a macro?
Thank you.
Pete

 

[Peter_SSs]

would it be possible for the amount dispensed to be written permanently to column D when the 'enter' key is pressed the first time?

Sure..
1. Remove the Worksheet_BeforeDoubleClick event code
2. Combine both operations (filter and add amounts) into the Worksheet_Change code as follows.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rSch As Range
  Dim s As String, sTest1 As String, sTest2 As String, FilterVals As String
  Dim aFltrVals As Variant, aNames As Variant, itm As Variant, FltrCrit As Variant
  Dim RX As Object, M As Object
  Dim i As Long, NumStrings As Long
  
  'Section to filter rows
  Set rSch = Range("SearchText")
  If Not Intersect(Target, rSch) Is Nothing Then
    Application.ScreenUpdating = False
    s = Application.Trim(rSch.Value)
    If ActiveSheet.FilterMode Then ShowAllData
    If Len(s) > 0 Then
      With Range("A1").CurrentRegion.Resize(, 3)
        NumStrings = UBound(Split(s)) + 1
        Set RX = CreateObject("VBScript.RegExp")
        RX.Global = True
        RX.IgnoreCase = True
        RX.Pattern = "(\b[^ ]*?)(" & Replace(s, " ", "|") & ")(?=[^ ]* )"
        sTest1 = "|" & Replace(s, " ", "||") & "|"
        aNames = .Columns(1).Value
        For i = 2 To UBound(aNames)
          Set M = RX.Execute(Replace(aNames(i, 1), Chr(160), " ") & " ")
          If M.Count >= NumStrings Then
            sTest2 = sTest1
            For Each itm In M
             sTest2 = Replace(sTest2, "|" & itm.submatches(1) & "|", "", 1, -1, 1)
            Next itm
            If sTest2 = vbNullString Then FilterVals = FilterVals & "|" & aNames(i, 1)
          End If
        Next i
        If Len(FilterVals) = 0 Then
          FltrCrit = "@@@"
        Else
          FltrCrit = Split(Mid(FilterVals, 2), "|")
        End If
          .AutoFilter Field:=1, Criteria1:=FltrCrit, Operator:=xlFilterValues
      End With
    End If
    Application.ScreenUpdating = True
  End If
  
  'Section to add amount dispensed
  If Target.Cells.Count = 1 Then
    If Target.Column = 3 And Target.Row > 1 And IsNumeric(Target.Value) Then
      Application.EnableEvents = False
      With Intersect(Target.EntireRow, Columns("D"))
        .Value = .Value + Target.Value
      End With
      Target.ClearContents  '<- Delete if not required
      Application.EnableEvents = True
      Range("SearchText").ClearContents '<- Delete if not required
    End If
  End If
End Sub

 

[peteprp]

I hope I did this correctly - I replaced the old code with the new code above. It seems to work but I get a 'Run-time error '-2147417848 (80010108)': Method 'ClearContents' of object 'Range' failed. When I click on 'Debug', the following is highlighted yellow: Target.ClearContents '<- Delete if not required.
Have I done something wrong?

 

[peteprp]

And on another occasion, when I click debug, the following line was highlighted yellow: .Value = .Value + Target.Value

 

[Peter_SSs]

The code worked for me & I may not be able to look at this again for a day or two.

Was the error message the same in the second example described?

 

[peteprp]

My apologies - it works great. The reason for the errors was that I had inserted a line above 'SearchText' cell to add a title for the worksheet. When I removed the line, it worked fine.
So my spreadsheet now looks like this, without the title. A1 & B1 are merged showing instructions.
Would it be possible to insert a line above row 1 for a title?
[TABLE="width: 614"]
<colgroup><col><col><col><col></colgroup><tbody>[TR]
[TD="colspan: 2"]Enter the name of the medication you are dispensing into the yellow cell, C1. It is a 'wild card' search - enter the first few letters and the strength or formulation then press enter, eg amox 500 or amox cap.
Then enter the amount to be dispensed in the 'blue-shaded' column (Col C) and press enter to store.[/TD]
[TD] C1 = 'SearchText'[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]GENERIC/ACTIVE INGREDIENTS[/TD]
[TD]UNITS[/TD]
[TD]Number Dispensed - PLEASE NOTE UNITS[/TD]
[TD]TOTALS D[/TD]
[/TR]
[TR]
[TD]Aciclovir 800mg Tabs [/TD]
[TD]Per Tab[/TD]
[TD][/TD]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD]Acyclovir Cream 5% 2g [/TD]
[TD]Ea[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Acyclovir Eye Ointment 3% 4.5g[/TD]
[TD]Ea[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Adrenaline autoInjector 300mcg [/TD]
[TD]Ea[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[/TR]
</tbody>[/TABLE]

Thank you again. And no rush to get back to me.

 

[Peter_SSs]

When I insert a new row 1 with heading, the existing code still works for me, though I would make the following small change in the bottom section.

If Target.Column = 3 And Target.Row > 2 And IsNumeric(Target.Value) Then

With the new row inserted, are the AutoFilter arrows showing in row 2 of your worksheet?

 

[peteprp]

Hi Peter. Have been working away from home so apologies for the late reply. That small change works great now. The AutoFilter now shows in row 1 only - I've merged A1,2 &3 for the title block. Is that a problem?

 

[Peter_SSs]

Is that a problem?

If your code is working as you want it isn't a problem. If the code is not working as you want it is a problem.

 

[peteprp]

The code is working fine. Thank you very much. I do have 2 further requests but I feel guilty asking you as you have done so much and been so helpful. I'll ask anyway but will totally understand if you have other commitments or feel that you have spent enough of your valuable time on this:

 

[peteprp]

My reply edit timed-out so I lost what I'd written down. Anyways, the first question was whether it would be possible for the cursor to return to cell C3 (SearchText) after having entered the amount dispensed for the particular medication? The second question is: I like to have an additional 3 sheets on separate tabs, one for Stock Receipts, one for Expired Stock and one for Stock Adjustments. Each of these sheets/tabs should be identical to the Dispense Stock sheet. I will then copy the cumulative totals of each sheet/tab to a separate sheet. I did try and copy the Dispense Stock sheet to a separate tab but it did not work. Hope this all makes sense. As mentioned, only if you have time. Thank you again.