VBA 在医院统计领域的应用探讨

李昕昊 周火明 赖伏虎 徐 俊 邓娟娟 罗 燕

1 香港大学深圳医院，518000 广东 深圳； 2 深圳市宝安纯中医治疗医院，518101 广东 深圳

visual basic for applications(简称VBA)是新一代标准宏语言，是基于visual basic for Windows 发展而来的。它与传统的宏语言不同，传统的宏语言不具有高级语言的特征，没有面向对象的程序设计概念和方法；而VBA 提供了面向对象的程序设计方法，提供了相当完整的程序设计语言[1]。

VBA没有自己独立的工作环境，须依附于某一个主应用程序。VBA专门用于Office的各应用程序中，如Word、 Excel、 Access等。它的编写是以子过程和函数为单位，在 Access中以模块形式出现。随着微软办公软件的普遍化，灵活掌握VBA语言的使用，可以让复杂的工作简易化，减少不必要的重复性工作，提高工作效率[2-3]。

本文将从医院日报制作、每月医疗质量公示数据自动生成拆分、临床科室多维度多指标数据查询3个项目阐述VBA在医院统计中的应用。

1 医院日报制作项目

1.1 制作流程

1)首先把门诊报表、病房报表从BI决策支持系统导出。

2)点击汇总模板中运行按钮，程序自动把门诊报表、病房报表中对应病区和科室的入院、出院、转科等数据依次进行填充。

3)因存在患者出院召回、护士忘记预约登记出院等原因，造成BI决策支持系统中数据与HIS系统的数据不一致，所以需进行校核。先导出HIS系统中入院、出院、转科的数据，再点击核查模板中运行按钮 ，程序自动将汇总模板的数据与从HIS系统导出的数据进行核对。

4)校核无误后，点击日报模板中运行按钮，日报模板自动从汇总模板中读取相关数据进行填充，日报模板数据填充完成，程序结束。见图1。

图1 医院日报制作流程图

1.2 部分VBA代码

1.2.1 填充门诊工作量代码

Sub huizong_deal()

Application.ScreenUpdating = False ""关闭屏幕刷新

Application.Calculation = xlCalculationManual ""关闭自动计算，加快运行速度

On Error Resume Next

Dim FilesToOpen, FilesToOpen2, FilesToOpen3, arr1, brr1, arr2, brr2

Dim wb1_name As String, wb2_name As String, wb3_name As String, wb_name As String

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook

Dim i As Integer, j As Integer, i2 As Integer

Dim IRang As Range, IRang2 As Range, IRang3 As Range

ActiveSheet.Select

wb_name = ActiveWorkbook.Name

""填充门诊工作量数据

FilesToOpen2 = Application.GetOpenFilename("Excel,*.xls;*.xlsx;*.xlsm", , "选择【门诊工作量报表(专科)】", , False)

If FilesToOpen2 = False Then

Exit Sub

Else

Set wb2 = Workbooks.Open(FilesToOpen2, 0)

End If

Workbooks(wb_name).Activate

For Each IRang2 In Workbooks(wb_name).ActiveSheet.Range("Q2:Q32")

For Each IRang3 In wb2.Sheets(1).Range("A5:A35")

If IRang2.Value = IRang3.Value Then

Workbooks(wb_name).ActiveSheet.Range("C" & IRang2.Row & ":" & "P" & IRang2.Row).Value = _

wb2.Sheets(1).Range("B" & IRang3.Row & ":" & "O" & IRang3.Row).Value

End If

Next

Next

Workbooks(wb_name).ActiveSheet.Range("Q2:Q32").ClearContents

""关闭专科表，不保存

wb2_name = wb2.Name

Workbooks(wb2_name).Close False

1.2.2 填充住院工作量代码

""打开病房日记表,如果不选择表，则退出

FilesToOpen = Application.GetOpenFilename("Excel,*.xls;*.xlsx;*.xlsm", , "选择【病房日记表】", , False)

If FilesToOpen = False Then

Exit Sub

Else

Set wb1 = Workbooks.Open(FilesToOpen, 0)

End If

wb1_name = wb1.Name

j = ActiveSheet.Range("A6666").End(xlUp).Row

ActiveSheet.Columns("D:F").Hidden = True′隐藏D:F列

ReDim arr2(1 To j - 1, 1 To 1)

ReDim brr2(1 To j - 1, 1 To 1)

For i2 = 1 To j - 1

If Cells(i2 + 1, 1).Value <> "" Then

arr2(i2, 1) = Cells(i2 + 1, 1)

brr2(i2, 1) = arr2(i2, 1) & Cells(i2 + 1, 3)

Else

arr2(i2, 1) = arr2(i2 - 1, 1)

brr2(i2, 1) = arr2(i2 - 1, 1) & Cells(i2 + 1, 3)

End If

Next

Range("P2:P" & j) = brr2

For i = 1 To j - 1

Windows(wb1_name).Activate

If VBA.IsError(Application.VLookup(Range("P" & i + 1), IRang, 1, 0)) Then

If Range("C" & i + 1).Value <> "" Then

Range("G" & i + 1 & ":L" & i + 1).Interior.ColorIndex = 44

Range("N" & i + 1).Interior.ColorIndex = 44

Else

End If

Else

a = Application.Match(Range("P" & i + 1), IRang, 0)

Workbooks(wb_name).Activate

ActiveSheet.Range("F"&71+a-1&":K"&71+a-1).Value= Workbooks(wb1_name).Sheets(1).Range("G" & i + 1 & ":L" & i + 1).Value

ActiveSheet.Range("M"&71+a-1).Value= Workbooks(wb1_name).Sheets(1).Range("N" & i + 1).Value

End If

Next

Workbooks(wb_name).Activate

ActiveSheet.Range("P71:P888").ClearContents′清除辅助列的数据

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

1.3 程序运行部分截图

程序运行部分截图见图2、图3。

图2 汇总模板填充门诊工作量数据

图3 数据自动导入日报模板

1.4 效果比较

某编制2 000张病床38个住院临床科室的三甲医院，在未使用此程序前，统计员每天需要花费4 h完成医疗运营日报数据的人工填充，校核以及生成，且时常出现复制粘贴错误、数据错行等问题。但自从使用VBA编码程序后，统计员只需要每天点击3个按钮，依次选择对应的Excel表格即可快速生成每天医疗运营日报。此过程花费不到10 min，不但提高了统计员的工作效率，而且数据质量也得到了很好的保障。

2 医疗质量公示数据项目

2.1 制作流程

1)首先收集12个职能部门关于临床科室共90个医疗质量指标和重点手术、重点病种数据；

2)对收集的Excel表格检查数据是否缺漏；

3)核查无误后，点击运行程序，输入即将生成医疗质量公示数据的年月份，点击确认，等待程序运行结束，共生成38个临床科室医疗质量公示数据表。

2.2 部分VBA程序代码

2.2.1 读取重点疾病和手术的路径、输入年月份的代码

Sub 医疗公示数据()

Application.ScreenUpdating = False′关闭屏幕更新

Application.DisplayAlerts = False′关闭警告开关

Dim FilesToOpen1, FilesToOpen2

Dim n As Byte, i As Byte, j As Byte, m As Byte, s As Byte

Dim wb1 As Workbook, wb2 As Workbook, wb1_again As Workbook

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet

Dim wb1_name As String, wb2_name As String, New_wb1_name As String, FilesAllname As String, NameLineName As String

Dim x1 As Integer, y1 As Long

Dim New_name, New_Path′定义新名称，新路径

Dim wb3 As Workbook, k As Byte, w As Byte, g As Byte

Dim yuefen As String′定义月份的文字

""需要确认是否修改了读取重点疾病和手术的路径，避免读取其他月份的数据

TS = MsgBox("是否已经更新重点疾病和手术手术的当月路径？", vbYesNo)

If TS <> vbYes Then

Exit Sub

Else

End If

""主动输入月份，避免忘记修改月份

yuefen = InputBox("请输入年月份", "hello", , 2500, 3500)

""专科重点疾病数据处理部分

Set wb1 = ActiveWorkbook

wb1_name = ActiveWorkbook.Name

FilesAllname = ActiveWorkbook.Path & "”& wb1_name '获取路径和名称，方便最后重新打开

New_Path = wb1.Sheets("指标数据抽取").Range("B6").Value ′最终导出文件的路径

""New_name = wb1.Sheets("指标数据抽取").Range("B3").Value

FilesToOpen1 = wb1.Sheets("指标数据抽取").Range("B1").Value′读取重点疾病数据路径

FilesToOpen2 = wb1.Sheets("指标数据抽取").Range("B2").Value′读取重点手术数据路径

2.2.2 遍历文件夹读取即将生成的科室名称

""通过读取文件夹的方式复制每个工作簿的那一行科室名称

f_name = Dir(wb1.Path & "〔.xlsx") ′搜索当前文件夹

Do While f_name <> ""

wb1_name = ActiveWorkbook.Name

Set wb1 = ActiveWorkbook

If f_name <> wb1_name Then

Set wb3 = Workbooks.Open(wb1.Path & "、" & f_name)

For w = 1 To wb3.Sheets.Count

For g = 1 To wb1.Sheets.Count

If wb3.Sheets(w).Name = wb1.Sheets(g).Name Then

If wb3.Sheets(w).Name = "基本质控指标" Or wb3.Sheets(w).Name = "基本质控指标 --IMC" Then

k = wb3.Sheets(w).UsedRange.Columns.Count

wb3.Sheets(w).Activate

wb3.Sheets(w).Range(Cells(2, 5), Cells(2, k)).Copy

wb1.Sheets(g).Activate

wb1.Sheets(g).Cells(2, 5).PasteSpecial Paste:=xlPasteValues

wb1.Sheets(g).Range(Cells(1, 1), Cells(1, k)).Merge ""合并标题单元格

wb1.Sheets(g).Range(Cells(2, 5), Cells(2, k)).Columns.AutoFit ""自动调节列宽

wb1.Sheets(g).Columns(k + 1).Resize(, 20 - k).Delete

End If

End If

Next

Next

On Error Resume Next

Dim arr1, d As Object ""字典，删除多余的表

Set d = CreateObject("scripting.dictionary")

ReDim arr1(1, 1 To wb3.Sheets.Count)

For w = 1 To wb3.Sheets.Count

arr1(1, w) = wb3.Sheets(w).Name

d(arr1(1, w)) = ""

Next

For g = 1 To wb1.Sheets.Count

If d.exists(wb1.Sheets(g).Name) Then

Else

wb1.Sheets(g).Delete

g = g - 1

End If

Next

Set d = Nothing

Set arr1 = Nothing

End If

wb3.Close False

f_name = Dir′找寻下一个excel文件，否则无限循环

2.2.3 读取各科室重点疾病数据代码

""专科重点疾病数据处理部分

Sub Savetime(ws1 As Worksheet, ws2 As Worksheet)

On Error Resume Next "如果后面的程序出现"运行时错误"时，会继续运行，不中断

Application.ScreenUpdating = False′关闭屏幕更新

Application.DisplayAlerts = False′关闭警告开关

Dim IRange As Range

Set IRange = ws2.Range("F:F")

ws1.Activate

x1 = ws1.UsedRange.Columns.Count′读取第二行的列数，方便统计有几个科室

ws1.Rows(2).Insert

For n = 4 To x1

ActiveSheet.Cells(2, n) = Application.WorksheetFunction.CountIf(IRange, Cells(3, n))

Next

y1 = Application.WorksheetFunction.Max(Range(Cells(2, 4), Cells(2, x1)))

Set ws1 = ActiveSheet

ActiveSheet.Range(Cells(4, 1), Cells(4 + (y1 - 1) * 9, 1)).Merge

For j = 4 To x1

m = 0

For i = 3 To ws2.Range("F6666").End(xlUp).Row

If ws1.Cells(3, j) = ws2.Cells(i, 6) Then

m = m + 1

If m = 1 Then

ws2.Activate

ws2.Range(Cells(i, 7), Cells(i, 15)).Copy

ws1.Activate

ws1.Cells(4, j).PasteSpecial Paste:=xlPasteValues, Transpose:=True

Else

ws2.Activate

ws2.Range(Cells(i, 7), Cells(i, 15)).Copy

ws1.Activate

ws1.Cells(4 + 9 * (m - 1), j).PasteSpecial Paste:=xlPasteValues, Transpose:=True

End If

End If

Next

Next

wb1.Activate

ws1.Rows(2).Delete′删除辅助行

ws1.Range("B3").Select′冻结窗体

ActiveWindow.FreezePanes = True

ws1.Rows("3:" & ws1.Range("B6666").End(xlUp).Row).AutoFit""自动调节行距

End Sub

2.3 程序运行部分截图

程序运行部分截图见图4。

图4 生成38个科室医疗质量公示数据Excel文件

2.4 效果比较

每月共38个临床科室，每个科室90个医疗质控指标和重点病种、重点手术明细数据，如果人工处理，统计员需要花费1 周的时间才能整理完成，并且数据经常出现错漏的情况，数据质量得不到保障。自从统计员使用此VBA程序后，效率快速提高，每月花费时

间不超过1 h就能完成，不再出现复制粘贴有误、错行等原因导致数据出错的现象。

3 Access多指标数据查询项目

3.1 项目背景

医院门诊、住院基本医疗数据查询需求量大，且时常要求统计员短时间内统计出结果，需求涉及三级公立医院绩效考核数据、住院医师培训基地督导、重点专科申报、科室诊疗质量基线调研、“3名工程”等。如果统计员使用广东省病案统计管理系统软件查询数据，不仅费时费力，而且存在软件运行效率低，操作不便等问题。所以运用VBA语言和数据库的原理研发Access多指标数据查询数据库，让数据查询速度更快，操作更加灵活便捷[4]。

3.2 部分VBA程序代码

3.2.1 更新基础数据中住院架构代码

Sub GX更新住院架构_Click()

DoCmd.Close acTable, "A新住院架构" '先关闭，否则会引起错误值

Call AddFile

If Len(AddFileName) = 0 Then

MsgBox "未选取工作簿，退出导入！", vbInformation + vbOKOnly, "信息提示"

Exit Sub

End If

ACName = CurrentProject.Name

' On Error GoTo End_Sub

Err.Clear′清除错误值

DoCmd.SetWarnings False′忽略警示

DoCmd.RunSQL "delete * From A新住院架构"

DoCmd.RunSQL "insert into A新住院架构(序号,大专科管理科室,专科管理科室,亚专科,绩效单元,直报分科单元,住院类型,科室名称,HIS科号,统一科号病案,维护科号病案)"&

_ "select 序号,大专科管理科室,专科管理科室,亚专科,绩效单元,直报分科单元,住院类型,科室名称,HIS科号,统一科号病案,维护科号病案"& _

DoCmd.SetWarnings True′恢复警示

MsgBox "住院架构更新导入成功！", vbInformation + vbOKOnly, "信息提示"

Exit Sub

End_Sub:

DoCmd.SetWarnings True′恢复警示

Msg = "错误编号 #"& Str(Err.Number) & "出错原因" _

& Err.Source & Chr(13) & Err.Description

MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext

End Sub

Function AddFile()

Dim FD As FileDialog

Set FD = Application.FileDialog(msoFileDialogOpen)

With FD

.FilterIndex = 15

.InitialFileName = ""

If .Show = -1 Then

AddFileName = .SelectedItems(1)

Else

AddFileName = ""

Exit Function

End If

End With

End Function

3.2.2 住院工作量多指标数据查询代码

""住院工作量

strsql = "SELECT A新住院架构.序号, A新住院架构.大专科管理科室, A新住院架构.专科管理科室, A新住院架构.亚专科, A新住院架构.绩效单元, " _

& "A新住院架构.直报分科单元, A新住院架构.住院类型,A新住院架构.HIS科号, 多指标源数据表.年月, " _

& zyzblx2 _

& " FROM A新住院架构 INNER JOIN 多指标源数据表 ON A新住院架构.HIS科号 = 多指标源数据表.HIS科号"

Set zysql = CurrentDb.CreateQueryDef("过程表", strsql)

strsql2 = "PARAMETERS [Forms]![多指标数据查询]![dzb_start时间] Text ( 255 ), [Forms]![多指标数据查询]![dzb_finish时间] Text ( 255 ), " _

& "[Forms]![多指标数据查询]![dzb_架构类型] Short;" _

& " SELECT 过程表.大专科管理科室," & Forms!多指标数据查询!dzb_架构类型 & "," & zyzblx _

& " FROM 过程表 " _

& "WHERE 过程表.住院类型 In (" & qylx & ")" _

& "And (int(过程表.年月) " _

& "Between Forms!多指标数据查询!dzb_start时间 And Forms!多指标数据查询!dzb_finish时间)" _

& " GROUP BY 过程表.序号,过程表.大专科管理科室," & Forms!多指标数据查询!dzb_架构类型 & " ORDER BY 过程表.序号"

Set zysql2 = CurrentDb.CreateQueryDef("多指标数据查询住院-" & qylxmc, strsql2) ""

DoCmd.OpenQuery zysql2.Name

Application.Echo True ""启用刷写屏幕

3.3 程序运行部分截图

程序运行部分截图见图5、图6。

图5 Access多指标数据查询主界面

图6 Access多指标数据查询结果(模拟数据)

3.4 效果比较

通过Access数据库的研发，医院统计员每次只需要选择符合的统计范围和指标类型，选择展现的架构类型，单击查询按钮运行程序，数据便会快速呈现，而不再使用广东省病案统计管理系统或撰写SQL脚本在SQL server数据库客户端进行查询，效率得到很大的提升。前期通过对Access数据库研发，可以根据自己的需求进行灵活设计，统计员平时只需维护基础表即可。Access数据库的使用保障了数据的稳定性，不会随着业务数据的变动或人为误操作而造成不同时间查询的指标数据不一致的现象，并且使用界面简洁，非专业编程人员也能熟悉使用。

4 小结

本文通过3个项目实例，介绍了VBA在医院统计领域的应用。VBA不仅能帮助医院统计员从日常重复枯燥的工作中摆脱出来，提高工作效率，从而专注于更高质量的脑力劳动，而且能保证数据质量。在医院信息化建设程度不高且没有更好的BI决策系统或RPA机器人等辅助工具的情况下[5]，采用VBA编程是一个不错的选择。VBA 易于学习掌握，医院统计员在日常工作中也可以使用宏记录器记录用户的各种操作并将其转换为VBA代码[6]，快速将日常工作转换为VBA 程序代码，使工作自动化。如遇到更复杂的需求，则需要了解VBA编程的编写逻辑，或者RPA机器人平台的“录像(record)”/“编辑(edit)”功能。总之，VBA是适用于医院统计应用场景的一种较好的工具，医院统计人员可在实际工作中掌握使用。