基于ExcelVBA技術的門診藥房特殊藥品日發藥統計程序設計

閆冰洋　李維鳳

摘 要：本文利用Excel VBA技術設計門診藥房特殊藥品日發藥統計程序，對日發藥明細表數據按日進行累加，得到每種藥品的日發藥明細數據，單次統計時間由原來的120 min以上降至2 min以內，提高了門診藥房藥品統計效率。

關鍵詞：門診藥房;Excel VBA;藥品統計

中圖分類號：R197.324文獻標識碼：A文章編號：1003-5168（2020）14-0021-03

The Statistical Program for Daily Delivery of Special Medicine in Outpatient Pharmacy Based On Excel VBA Technology

YAN Bingyang LI Weifeng

（School of Pharmacy， Medical College of Xi'an Jiaotong University，Xi'an Shaanxi 710061）

Abstract： This paper used Excel VBA technology to design a statistical program for daily delivery of special medicines in outpatient pharmacies， and accumulated daily delivery schedule data to obtain daily delivery breakdown data for each medicine. The single statistical time was reduced from more than 120 min to less than 2 min， which improved the efficiency of drug statistics in outpatient pharmacy.

Keywords： outpatient pharmacy;Excel VBA;drug statistics

隨著國家政策導向、藥學學科及技術的發展，藥學工作人員的工作重心逐步從發藥向提供合理的用藥藥學服務轉變，在這個過程中，越來越多的工作也會被賦予藥學工作人員，門診藥房藥師的工作也日漸繁重。隨著國家對藥品日常監控的深入，門診藥房不僅要完成日常工作，還要每月配合相關部門完成特殊藥品的統計工作，如終止妊娠藥品、醫保指定藥品等的日發藥統計工作，而HIS系統由于引進時間較長不具備這項功能，每月的統計工作耗時耗力。VBA是一種宏語言，結合微軟辦公軟件很容易將日常工作流程轉換為VBA程序代碼，使藥學工作實現自動化，如利用藥庫智能化辦公[1]、VBA編制中藥采購軟件[2]、開發藥品配伍禁忌審查表[3]等。

本文將從門診藥房特殊藥品日發藥統計實際工作入手，分析目前工作的不足，利用Excel VBA語言設計特殊藥品日發藥統計程序，以提高特殊藥品日發藥統計效率。

1 資料與方法

1.1 特殊藥品日發藥統計程序的算法構建

該程序的整體思路是：建立待統計特殊藥品清單，設計特殊藥品日發藥統計程序的算法，導入HIS系統導出的日發藥明細表，得到每種藥品的日發藥明細數據。

因庫存藥品存在同名稱、多規格、多廠家的情況，只檢索藥品名稱無法確定藥品的唯一性，故采用藥典編號確定藥品的唯一性。

1.1.1 日發藥明細表。選擇起始日期及終止日期，從醫院HIS系統查詢導出日發藥明細表，保存成“.xls”格式。導出的日發藥明細表格式如表1所示。

1.1.2 庫存盤點表排序與排版。為保證庫存盤點有序進行，根據貨架位置進行排序，并進行排版。

1.2 特殊藥品日發藥統計程序設計

程序包括導入HIS系統導出的日發藥明細、統計指定藥品日發藥明細等過程。

從HIS系統中導出日發藥明細表，導入門診藥房特殊藥品日發藥統計程序，保存在數組arr_rfyyssj中，利用字典統計指定品種的藥品日發藥明細[4-5]，VBA代碼示例如下：

Sub 指定品種日發藥明細 （）

Dim wb As Workbook

Dim sht_db As Worksheet

Dim sht1 As Worksheet

Dim sht_fymx As Worksheet

Dim i， k

Dim arr_rfyyssj， arr_yfy， arr_rq， arr_cxpz， arr_bt '日發藥原始數據，發藥數據，日期，查詢品種，標題

Dim dict_ydbh As Object， dict_yfy As Object， dict_rq As Object ? '藥典編號單位，月發藥數量

Set dict_ydbh = CreateObject（"Scripting.Dictionary"）

Set dict_yfy = CreateObject（"Scripting.Dictionary"）

Set dict_rq = CreateObject（"Scripting.Dictionary"）

Set sht_db = ThisWorkbook.Worksheets（"datebase"）

Set sht1 = ThisWorkbook.Worksheets（"sheet1"）

Set sht_fymx = ThisWorkbook.Worksheets（"日發藥明細"）

Application.ScreenUpdating = False

Cells.Borders.LineStyle = xlNone

arr_cxpz = sht_fymx.[A1].Resize（[A1].End（xlDown）.Row， 26）

'清除歷史數據

[C3].Resize（UBound（arr_cxpz， 1）， 40） = ""

For i = 3 To UBound（arr_cxpz， 1）

dict_ydbh（arr_cxpz（i， 1）） = ""

Next i

Set wb = Workbooks.Open（sht_db.[Q7].Value）

arr_rfyyssj = wb.Worksheets（1）.Range（"B1"）.Resize（Cells（[A1].End（xlDown）.Row， 2）.End（xlUp）.Row， 26）

wb.Close

For i = 2 To UBound（arr_rfyyssj， 1）

If dict_ydbh.exists（arr_rfyyssj（i， 26）） Then

dict_rq（Format（arr_rfyyssj（i， 14）， "m/d"）） = arr_rfyyssj（i， 6） & "-" & arr_rfyyssj（i， 7） & "-" & arr_rfyyssj（i， 8）

dict_yfy（arr_rfyyssj（i， 26）） = arr_rfyyssj（i， 6） & "-" & arr_rfyyssj（i， 7） & "-" & arr_rfyyssj（i， 8）

dict_yfy（arr_rfyyssj（i， 26） & "/" & Format（arr_rfyyssj（i， 14）， "m/d"）） = dict_yfy（arr_rfyyssj（i， 26） & "/" & Format（arr_rfyyssj（i， 14）， "m/d"）） + arr_rfyyssj（i， 11）

End If

Next i

arr_yfy = Application.Transpose（dict_ydbh.keys）

arr_rq = Application.Transpose（dict_rq.keys）

ReDim Preserve arr_yfy（1 To dict_ydbh.Count， 1 To dict_rq.Count + 2）

For i = 1 To UBound（arr_yfy， 1）

arr_yfy（i， 2） = dict_yfy（arr_yfy（i， 1））

For k = 1 To dict_rq.Count

arr_yfy（i， 2 + k） = dict_yfy（arr_yfy（i， 1） & "/" & arr_rq（k， 1））

Next k

Next i

ReDim arr_bt（1 To 1， 1 To UBound（arr_rq， 1） + 2）

For i = 1 To UBound（arr_rq， 1）

arr_bt（1， i + 2） = arr_rq（i， 1）

Next i

arr_bt（1， 1） = "藥典編號"

arr_bt（1， 2） = "藥品信息"

sht_fymx.[A2].Resize（1， UBound（arr_bt， 2）） = arr_bt

sht_fymx.[A3].Resize（dict_ydbh.Count， dict_rq.Count + 2） = arr_yfy

'自動居中，適合單元格調整字體

With [C2].Resize（UBound（arr_yfy， 1） + 1， UBound（arr_yfy， 2） - 2）

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ShrinkToFit = True

End With

With [A2].Resize（UBound（arr_yfy， 1） + 1， 1）

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ShrinkToFit = True

End With

'添加邊框線

With [A2].Resize（UBound（arr_yfy， 1） + 1， UBound（arr_yfy， 2））.Borders

.LineStyle = xlContinuous

.Weight = xlThin

End With

ActiveSheet.PageSetup.PrintTitleRows = "$1：$2"