中药处方笺 VBA

时　间:2011-10-26 17:16:46
作　者:欢乐小爪   ID：20149  城市：杭州
摘　要:中药处方笺 VBA
正　文:

*************简拼模块*******************

Public Function MyPY(ByVal vText As Variant) As String
Application.Volatile
Dim strResult As String
Dim lStart As Long
On Error Resume Next
For lStart = 1 To Len(vText)
strResult = strResult & Application.Evaluate("VLookup(""" & Mid(vText, lStart, 1) & _
""",{""吖"",""A"";""八"",""B"";""嚓"",""C"";""咑"",""D"";""鵽"",""E"";""发"",""F"";""猤"",""G"";""铪"",""H"";""夻"",""J"";""咔"",""K"";""垃"",""L"";""嘸"",""M"";""旀"",""N"";""噢"",""O"";""妑"",""P"";""七"",""Q"";""囕"",""R"";""仨"",""S"";""他"",""T"";""屲"",""W"";""夕"",""X"";""丫"",""Y"";""帀"",""Z""},2,1)")
 Next
MyPY = strResult
End Function

*************中药处方笺工作表模块*******************

Public arr, X, I, Hx, K

采用双击比较顺手---

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If Me.ListBox1.ListIndex > 0 Then
K = Me.ListBox1.ListIndex
Call CR
End If
End Sub

采用键盘输入代码---

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 And Me.ListBox1.ListIndex > 0 Then
K = Me.ListBox1.ListIndex
Call CR '键盘 Enter 键
ElseIf KeyCode > 48 And KeyCode < 58 Then
K = KeyCode - 48 '键盘1-9键
Call CR
ActiveCell.Offset(1).Select
ElseIf KeyCode = 37 Then
Me.TextBox1.Activate '键盘 左 键
ElseIf KeyCode = 27 Then
Call QC '键盘 Esc 键
End If
End Sub

----------------------文本框变化事件显示列表框内容-------------------------------

Private Sub TextBox1_Change()
If TextBox1.Value <> "" Then
For I = 1 To Len(TextBox1.Value)
If Not (Mid(TextBox1.Value, I, 1) Like "[A-Z a-z ]") Then
MsgBox " 请输入简拼字母", 64, "小爪提示"
Exit Sub
End If
Next I

Hx = Sheets("中药处方信息").Range("b65536").End(xlUp).Row
arr = Sheets("中药处方信息").Range("a1:e" & Hx)
X = 2
For I = 2 To UBound(arr)
If InStr(arr(I, 5), LCase(TextBox1.Value)) > 0 Then '按拼音转化小写简写查找
arr(X, 1) = X - 1 '序号
arr(X, 2) = arr(I, 2) '品名
arr(X, 3) = arr(I, 3) '单位
arr(X, 4) = arr(I, 4) '价格
arr(X, 5) = arr(I, 5) '拼音简写
X = X + 1
End If
Next
If X > 2 Then
Sheets("中药处方信息").Range("J1").Resize(X, 5) = arr
ReDim arr(X, 4)
arr = Sheets("中药处方信息").Range("J1:N" & X - 1)
Me.ListBox1.Clear
Me.ListBox1.List = arr
Sheets("中药处方信息").Range("J:N").Clear
End If
Else
Me.ListBox1.Clear
End If
End Sub

----------------------文本框变化事件-------------------------------

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then '键盘 Enter 键
If TextBox1.Value = "" Then
ActiveCell.Offset(0, -1).Resize(1, 5).Borders.LineStyle = xlNone
ActiveCell.Offset(0, -1).Resize(1, 5).Value = ""
Call QC
Else
K = 1
Call CR
ActiveCell.Offset(1).Select
End If
ElseIf KeyCode = 38 Then
ActiveCell.Offset(-1).Select '键盘 上 键
ElseIf KeyCode = 40 Then
ActiveCell.Offset(1).Select '键盘 下 键
ElseIf KeyCode = 27 Then
Call QC '键盘 ESC 键
End If
With Me.ListBox1
If KeyCode = 39 And .ListCount > 0 Then '键盘 右 键
If .ListCount > 1 Then .ListIndex = 1 Else .ListIndex = -1
.Activate
End If
End With
End Sub

----------------------工作表变化事件调动文本框-------------------------------

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I As Integer
Dim arrk
Dim jiner As Double
With Target
If .Count = 3 And (.Column = 2 Or .Column = 6 Or .Column = 10) And .Row > 8 And .Row < 24 Then
With Me.TextBox1
.Value = ""
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height
.Activate
.Visible = True
End With
With Me.ListBox1
.ColumnHeads = False
.ColumnWidths = "35;60;35;50;60"

.ListStyle = fmListStylePlain
.Top = Target.Top
.Left = Target.Left + Target.Width
.Width = 250
.Height = 150
.Visible = True
End With
Else
Call QC
End If
' ------------------------------
If .Count = 1 And (.Column = 5 Or .Column = 9 Or .Column = 13) And .Row > 8 And .Row < 24 Then
If Not (IsNumeric(Target.Value)) Then
MsgBox " 请输入数字", 64, "小爪提示"
Target.Value = ""
Exit Sub
End If

' --------------------------------
If .Column > 0 And .Column < 14 And .Row > 8 And .Row < 24 Then
Hx = Sheets("中药处方信息").Range("b65536").End(xlUp).Row
arrk = Sheets("中药处方信息").Range("a1:e" & Hx)
End If
For j = 9 To 23
For jj = 5 To 13 Step 4
If Cells(j, jj) <> "" And Cells(j, jj - 3) <> "" Then
For jjj = 2 To UBound(arrk)
If arrk(jjj, 2) = Cells(j, jj - 3) Then
jiner = jiner + Round(arrk(jjj, 4) * Cells(j, jj), 2) '价格
End If
Next

End If
Next
Next
'药品金额
Sheets("中药处方笺").Range("D25") = jiner

End If
End With
End Sub

---------------------------------------------
Sub CR()
On Error Resume Next
With ActiveCell
.Value = Me.ListBox1.List(K, 1)

' .Offset(, 2).Value = Me.ListBox1.List(K, 3)
' .Offset(, -1).Value = ActiveCell.Row - 4
' .Offset(, -1).Resize(1, 5).Borders.LineStyle = 1

End With
ActiveCell.Offset(0, 1).Select
End Sub

---------------------------------------------

Sub QC()
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
Me.TextBox1.Value = ""
End Sub

函数版本处方签