闫冰洋　李维凤

摘 要：本文利用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"