打印挂号患者名单_VBA

这是在Excel中使用VBA写的一个打印患者挂号名单的程序。

需求：所在医院的颌面外科门诊在比较忙碌的时候，往往难以在患者处理后立即将病历完成，所以需要将患者的一些信息做一下记录，方便稍后完成病历。一般的方法是将患者的姓名誊写下来，当时就诊系统可以导出患者挂号信息到excel，只是格式不是我们所需要的——我们只需要患者的名字——但是可以从导出信息里面提取姓名并打印出来以完成这个需求。

导出信息的格式如下：

程序的代码如下：

将提取姓名并打印的功能加入右键菜单

因为打印的时候下午的号可能还没挂完，所以有三个打印范围：上午、下午、所有。

Sub addcellMenu()
    Dim custMenu As CommandBar
    Dim subMenu As CommandBarControl
    
    Call deletecellMenu
    
    Set custMenu = Excel.Application.CommandBars("Cell")
    Set subMenu = custMenu.Controls.Add(msoControlPopup, , , 1)
    
    With subMenu
        .Caption = "打印挂号名单"
        
        With .Controls.Add(msoControlButton)
            .Caption = "打印上午挂号名单"
            .OnAction = "'" & ThisWorkbook.name & "'!打印上午挂号名单"
            .FaceId = 164
        End With
        
        With .Controls.Add(msoControlButton)
            .Caption = "打印下午挂号名单"
            .OnAction = "'" & ThisWorkbook.name & "'!打印下午挂号名单"
            .FaceId = 164
        End With
        
        With .Controls.Add(msoControlButton)
            .Caption = "打印所有挂号名单"
            .OnAction = "'" & ThisWorkbook.name & "'!打印所有挂号名单"
            .FaceId = 164
        End With
        
        Set subMenu = Nothing
        Set subMenu = Nothing
    End With
End Sub

提取姓名并打印的VBA代码

加入了一些选择逻辑，比如输错挂号书要重新输入等，可以根据需要修改。虽然有三个打印范围，但是代码是差不多的，所以以’打印上午挂号名单’代码为例。

Sub 打印上午挂号名单()
'
' 打印上午名单 Macro
'

'
    
inputAgain:
    
    Dim response As String
    
    response = MsgBox("是否开始执行提取姓名并打印？", vbOKCancel)
    If response = vbOK Then
        '新建表单sheet2以供粘贴
        Sheets.Add After:=Worksheets(1)
        ActiveSheet.name = "sheet2"
        Sheets("Sheet1").Select
    
        '使用MID()函数提取姓名
        Range("M5").Select
        ActiveCell.FormulaR1C1 = "=MID(RC[-2],FIND(""姓名"",RC[-2])+3,4)"
        Range("M5").Select
    
        '选中上午患者,并粘贴到sheet2
        Dim copyrange As String, copyrange1 As String, i As Integer, _
            k As Integer, j As Integer, lastrow As Integer
            j = Application.InputBox("请输入上午挂号数", Type:=1)
            lastrow = j + 4
            copyrange1 = "M5" & ":" & "M" & lastrow
        Selection.AutoFill Destination:=Range(copyrange1), Type:=xlFillDefault
        Range(copyrange1).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    
        '删除错误值：没有挂出去的号按照前面的提取方式会显示错误值(#VALUE!)，需要删除
        Dim l As Long
        For l = 1 To j
            If Cells(l, 1).Text = "#VALUE!" Then
                Rows(l).Delete
                l = l - 1
            End If
        Next l
    
   
        '插入空行，为后面备注患者信息留出空间
        For k = Range("A65536").End(xlUp).Row To 2 Step -1
            Rows(k).Insert
        Next k
        
        '调整格式如字体大小等
        Columns("A:A").Select
        With Selection.Font
            .name = "Arial"
            .Size = 18
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
    
    
        '打印并显示信息
        Dim ans As String, ans1 As String, ans2 As String
        
        'ans2是随便命名的一个变量，用于提取医生姓名
        ans2 = Worksheets("Sheet1").Range("D5").Value
        
        With Sheets("sheet2").PageSetup
            .CenterFooter = "第 &P/&N 页"
            .CenterHeader = Date & "上午已挂号名单(" & ans2 & "):"
        End With
        
        ans = MsgBox("请确认" & vbNewLine & vbTab & "上午挂号数：" & j, vbOKCancel, "即将开始打印！")
        If ans = vbOK Then
            Sheets("sheet2").PrintOut
            MsgBox "提取姓名并打印完毕"
            Application.DisplayAlerts = False
            Application.Quit  '退出工作簿
        ElseIf ans = vbCancel Then
            ans1 = MsgBox("退出？", vbYesNo)
            If ans1 = vbYes Then
                Application.DisplayAlerts = False
                Application.Quit  '退出工作簿
                
                Exit Sub
            Else
                Application.DisplayAlerts = False
                Sheets("Sheet2").Delete
                Sheets("sheet1").Columns("M:M").Clear
                GoTo inputAgain
            End If
        End If
           
    Else
        Application.DisplayAlerts = False
        Application.Quit  '退出工作簿
        
        Exit Sub
    End If
   
End Sub