エクセルマクロで作った透析データベース～処方箋個別印刷

処方箋をお一人分ずつ印刷するためのマクロです。

フォームは経過表の個別印刷で使っている物とほぼ同じ物です。一番下のチェックボックスを選択することで印刷したい曜日を選べます。
処方があるところだけ選択可能なチェックボックスを設置しております。（処方が出ていないところは「処方なし」の文字が出て選択不可能になります）

Dim Touseki As Object, Syohou As Object
Dim MaxRows As Long
Dim Kensaku As String
Dim UserData As String
Dim UserNData1 As Date
Dim UserNData2 As String
Dim UserNData3 As Date
Dim UserNData4 As Object
Dim CelRow As Long
Dim CelNo As String
Dim Simei As String
Dim LoopCount As Integer
Dim WorkArea As String
Dim CellAddress As String
Dim Flag As Boolean
Dim A As Integer
Dim Z As Integer
Dim S As Integer
Dim Syoho(1, 11) As Integer


Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Set Syohou = Worksheets("院外処方箋")
    MaxRows = Touseki.UsedRange.Rows.Count
    ‘RowPos = 2
    Syoho(0, 0) = 133
    Syoho(0, 1) = 134
    Syoho(0, 2) = 135
    Syoho(0, 3) = 136
    Syoho(0, 4) = 137
    Syoho(0, 5) = 138
    Syoho(0, 6) = 139
    Syoho(0, 7) = 140
    Syoho(0, 8) = 141
    Syoho(0, 9) = 142
    Syoho(0, 10) = 143
    LoopCount = 3
    Do
        Do
            If Touseki.Cells(LoopCount, 2) = "" Then
                LoopCount = LoopCount + 1
                Exit Do
            End If
            CelNo = "B" & LoopCount
            Simei = Worksheets("透析患者リスト").Range(CelNo)
            SyohouMan.ListBox1.AddItem (Simei)
            LoopCount = LoopCount + 1
            ‘RowPos = RowPos + 1
        Loop While Simei <> ""
    Loop While LoopCount < MaxRows
   
End Sub

‘不変部
Sub Insatsu_Syohou(ByVal CelTate As Integer, ByVal CelCol As Integer)

    Syohou.Activate

    UserData = Touseki.Cells(CelTate, 2).Value
    Syohou.Range("D14") = UserData
    UserData = Touseki.Cells(CelTate, 3).Value
    Syohou.Range("D13") = UserData
    UserData = Touseki.Cells(CelTate, 4).Value
    Syohou.Range("F16") = UserData
    UserNData1 = Touseki.Cells(CelTate, 5)
    Syohou.Range("D16") = UserNData1
    UserData = Touseki.Cells(CelTate, 6).Value
    Syohou.Range("E15") = UserData
    UserData = Touseki.Cells(CelTa
te, 20).Value
    Syohou.Range("H9") = UserData
    UserData = Touseki.Cells(CelTate, 21).Value
    Syohou.Range("H11") = UserData
    UserData = Touseki.Cells(CelTate, 22).Value
    Syohou.Range("D10") = UserData
    UserData = Touseki.Cells(CelTate, 23).Value
    Syohou.Range("D11") = UserData
    UserData = Touseki.Cells(CelTate, 24).Value
    Syohou.Range("I35") = UserData
    UserData = Touseki.Cells(CelTate, 25).Value
    Syohou.Range("I37") = UserData
   
‘可変部
   
    UserNData3 = Touseki.Cells(CelTate, 30 + CelCol)
    Syohou.Range("E20") = UserNData3
    UserData = Touseki.Cells(CelTate, Syoho(0, 0) + CelCol * 12).Value
    Syohou.Range("D22") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 1) + CelCol * 12).Value
    Syohou.Range("D23") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 2) + CelCol * 12).Value
    Syohou.Range("D24") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 3) + CelCol * 12).Value
    Syohou.Range("D25") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 4) + CelCol * 12).Value
    Syohou.Range("D26") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 5) + CelCol * 12).Value
    Syohou.Range("D27") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 6) + CelCol * 12).Value
    Syohou.Range("D28") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 7) + CelCol * 12).Value
    Syohou.Range("D29") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 8) + CelCol * 12).Value
    Syohou.Range("D30") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 9) + CelCol * 12).Value
    Syohou.Range("D31") = UserData
    UserData = Touseki.Cells(CelTate, Syoho(0, 10) + CelCol * 12).Value
    Syohou.Range("D32") = UserData
    ‘UserData = Touseki.Cells(CelTate, Syoho(0, 11) + CelCol * 12).Value
    ‘Syohou.Range("D33") = UserData
   
    Application.Wait (Now + TimeValue("0:00:03"))
    With Syohou
        .PrintOut preview:=False
    End With
                          
End Sub

Private Sub CommandButton4_Click()
    Unload SyohouMan
    AboutForm.Show
    ‘End
End Sub


Private Sub ListBox1_Click()
    Dim Kotae As Byte
   
    Kensaku = SyohouMan.ListBox1.Text
   
    WorkArea = "B1:B" & MaxRows
   
    Set Result = Touseki.Range(WorkArea).Find(what:=Kensaku, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlN
ext, MatchCase:=False)
    CellAddress = Result.Address
    StrCount = Len(CellAddress)
    CellAddress = Right(CellAddress, StrCount – 3)
    CelRow = CellAddress
   
    UserData = Touseki.Cells(CelRow, 2).Value
    SyohouMan.Label3.Caption = UserData
    If UserData <> "" Then
        SyohouMan.CommandButton3.Enabled = True
    End If
       
    SyohouMan.CheckBox1.Value = False
    SyohouMan.CheckBox2.Value = False
    SyohouMan.CheckBox3.Value = False
   
    Kotae = 空欄か空欄ではないか､それが問題だ(CelRow, Syoho(0, 0))
    If Kotae = False Then
        UserData = Touseki.Cells(CelRow, 33).Value
        SyohouMan.CheckBox1.Caption = UserData
        SyohouMan.CheckBox1.Enabled = True
    Else
        SyohouMan.CheckBox1.Caption = "処方なし"
        SyohouMan.CheckBox1.Enabled = False
    End If
   
    Kotae = 空欄か空欄ではないか､それが問題だ(CelRow, Syoho(0, 0) + 12)
    If Kotae = False Then
        UserData = Touseki.Cells(CelRow, 34).Value
        SyohouMan.CheckBox2.Caption = UserData
        SyohouMan.CheckBox2.Enabled = True
    Else
        SyohouMan.CheckBox2.Caption = "処方なし"
        SyohouMan.CheckBox2.Enabled = False
    End If
   
    Kotae = 空欄か空欄ではないか､それが問題だ(CelRow, Syoho(0, 0) + 24)
    If Kotae = False Then
        UserData = Touseki.Cells(CelRow, 35).Value
        SyohouMan.CheckBox3.Caption = UserData
        SyohouMan.CheckBox3.Enabled = True
    Else
        SyohouMan.CheckBox3.Caption = "処方なし"
        SyohouMan.CheckBox3.Enabled = False
    End If
End Sub
Private Function 空欄か空欄ではないか､それが問題だ(ByVal Tate As Integer, Hikisu As Integer) As Byte

    For i = 0 To 10
        If Touseki.Cells(Tate, Hikisu + i) <> "" Then
            空欄か空欄ではないか､それが問題だ = False
   
            Exit For
        Else
            If i = 10 Then
                空欄か空欄ではないか､それが問題だ = True
            End If
        End If
    Next
   
End Function

Private Sub CommandButton3_Click()
    Kensaku = SyohouMan.ListBox1.Text
    Set Touseki = Worksheets("透析患者リスト")
    Set Syohou = Worksheets("院外処方箋")
    MaxRows = Touseki.UsedRange.Rows.Count
    WorkArea = "B1:B" & MaxRows
    Syohou.Select
   
    SyohouMan.Hide
    Set Result = Touseki.Range(WorkArea).Find(what:=Kensaku, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                CellAddress = Result.Address
                StrCount = Len(CellAddress)
                CellAddress = Right(CellAddress, StrCount – 3)
                CelRow = CellAddress
   
    If SyohouMan.CheckBox1.Value = True Then
        CelCol = 0
        Call Insatsu_Syohou(ByVal CelRow, ByVal CelCol)
    End If
    If SyohouMan.CheckBox2.Value = True Then
        CelCol = 1
        Call Insatsu_Syohou(ByVal CelRow, ByVal CelCol)
    End If
    If SyohouMan.CheckBox3.Value = True Then
        CelCol = 2
        Call Insatsu_Syohou(ByVal CelRow, ByVal CelCol)
    End If
   
    SyohouMan.Show
    MsgBox ("印刷終了")
   
End Sub