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.

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

<tbody>
</tbody>

Search Drug Name:

For example, type in amox 25 c

<tbody>
</tbody>

Then show result below together with Units column & add
the number of capsules dispensed in the column alongside
		Enter Number Dispensed
Amoxycillin Caps 250mg	Per Caps	5​

<tbody>
</tbody>

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?

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.	C1 = 'SearchText'
GENERIC/ACTIVE INGREDIENTS	UNITS	Number Dispensed - PLEASE NOTE UNITS	TOTALS D
Aciclovir 800mg Tabs	Per Tab		7
Acyclovir Cream 5% 2g	Ea
Acyclovir Eye Ointment 3% 4.5g	Ea
Adrenaline autoInjector 300mcg	Ea		1

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

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.