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

１週間分の処方箋を自動で印刷するためのフォームです。

Dim Touseki As Object
Dim Syohou As Object
Dim RowPos As Integer
Dim iro As Integer
Dim MaxRows As Long
Dim CelNo As String
Dim Simei As String
Dim UserData As String
Dim UserNData1 As Date
Dim UserNData2 As String
Dim UserNData3 As Date
Dim UserNData4 As Object
Dim Tcolor As Byte
Dim MarkIngai As Integer
Dim Syoho(1, 11) As Integer

Private Sub UserForm_Initialize()
    MarkIngai = 132
    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

    RowPos = 3

    Set Touseki = Worksheets("透析患者リスト")
    Set Syohou = Worksheets("院外処方箋")
    MaxRows = Touseki.UsedRange.Rows.Count

    Syohou.Activate
End Sub

Private Sub LupinThe3rd()
    SyohouAuto.Hide
    Set Touseki = Worksheets("透析患者リスト")
    Do
        iro = Touseki.Cells(RowPos, 1).Interior.ColorIndex
        Do While iro = Tcolor
            If Touseki.Cells(RowPos, 1).Interior.ColorIndex <> Tcolor Then
                Exit Do
            End If
            If Touseki.Cells(RowPos, MarkIngai) <> "院外処方" Then
                Exit Do
            End If
            For K = 0 To 2
                Kotae = 空欄か空欄ではないか､それが問題だ(RowPos, Syoho(0, 0) + K * 12)
                If Kotae = False Then
                    Call Insatsu_Syohou(ByVal RowPos, ByVal K)
                End If
            Next
            RowPos = RowPos + 1
        Loop
        RowPos = RowPos + 1
    Loop While RowPos <= MaxRows

    Unload SyohouAuto
End Sub

Private Sub CommandButton1_Click()
‘赤
    Tcolor = 3
    LupinThe3rd
End Sub

Private Sub CommandButton2_Click()
‘青
    Tcolor = 5
    LupinThe3rd
End Sub

Private Sub CommandButton3_Click()
‘黄色
    Tcolor = 6
    LupinThe3rd
End Sub

Private Sub CommandButton4_Click()
‘緑
    Tcolor = 4
    LupinThe3rd
End Sub

Private Sub CommandButton5_Click()
    Unload SyohouAuto
    AboutForm.Show
    ‘End
End Sub

Sub Insatsu_Syohou(ByVal CelTate As Integer, ByVal CelCol As Integer)

    Set Touseki = Worksheets("透析患者リスト")
    Set Syohou = Worksheets("院外処方箋")

    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(CelTate, 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("H22") = UserData

        Syohou.Activate

        Application.Wait (Now + TimeValue("0:00:07"))
        With Syohou
            .PrintOut preview:=False
        End With
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