エクセルマクロで作った透析データベース～経過表個別印刷フォーム

このフォームは透析の経過表を個別印刷するためのものです。個別印刷とは全員分の印刷ではなくて患者さんを指定して印刷する方法です。曜日を指定して印刷することもできます。 

Dim Touseki As Object
Dim Keika As Object
‘Dim Pos As Integer
Dim UserData As String
Dim UserNData1 As Date
Dim UserNData2 As String
Dim UserNData3 As Date
Dim UserNData4 As Object
Dim CelPos As String
Dim CelTate As Long
Dim CelNo As String
Dim Simei As String
Dim LoopCount As Integer
Dim MaxRows As Long
Dim WorkArea As String
Dim CellAddress As String
Dim Kensaku As String
Dim A As Integer
Dim Hiduke(3) As String

Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Set Keika = Worksheets("平成16年度版経過表")
    LoopCount = 3
   
    Do
        If Touseki.Cells(LoopCount, 2) = "" Then
             Exit Do
        End If
        CelNo = "B" & LoopCount
        Simei = Worksheets("透析患者リスト").Range(CelNo)
        KeikahyouMan.ListBox1.AddItem (Simei)
        LoopCount = LoopCount + 1

    Loop While Simei <> ""
    
    KeikahyouMan.ListBox1.ListIndex = 0
    OptionButton4_Click
    
End Sub


Private Sub CommandButton3_Click()
    Dim CelYoko As Integer
    
    Kensaku = KeikahyouMan.ListBox1.Text

    MaxRows = Touseki.UsedRange.Rows.Count
    WorkArea = "B1:B" & MaxRows
    Keika.Select
    
    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)
                CelTate = CellAddress
                
    KeikahyouMan.Hide
    
                
    ‘不変部
    Keika.Range("R14").Activate
    UserData = Touseki.Cells(CelTate, 1).Value
    Keika.Range("R14") = UserData
    UserData = Touseki.Cells(CelTate, 2).Value
    Keika.Range("R18") = UserData
    UserNData1 = Touseki.Cells(CelTate, 5)
    Keika.Range("BB14") = UserNData1
    UserData = Touseki.Cells(CelTate, 6).Value
    Keika.Range("CG14") = UserData
    UserData = Touseki.Cells(CelTate, 7).Value
    Keika.Range("BJ19") = UserData
    UserData = Touseki.Cells(CelTate, 8).Value
    Keika.Range("CF19") = UserData
    UserData = Touseki.Cells(CelTate, 9).Value
    Keika.Range("DE35") = UserData
    UserData = Touseki.Cells(CelTate, 10).Value
    Keika.Range("DE40") = UserData
    UserData = Touseki.Cells(CelTate, 11).Value
    Keika.Range("BV32") = UserData
    UserData = Touseki.Cells(CelTate, 12).Value
    Keika.Range("DG19") = UserData
    UserData = Touseki.Cells(CelTate, 13).Value
    Keika.Range("DG24") = UserData
    UserData = Touseki.Cells(CelTate, 14).Value
    Keika.Range("DG30") = UserData
    UserData = Touseki.Cells(CelTate, 15).Value
    Keika.Range("BA25") = UserData
    UserData = Touseki.Cells(CelTate, 16).Value
    Keika.Range("BA32") = UserData
    
    
    Application.Wait (Now + TimeValue("0:00:02"))

    ‘可変部印刷の準備

    For i = 0 To 2
        Hiduke(i) = Touseki.Cells(CelTate, 33 + i)
    Next
    
    If OptionButton1.Value = True Then
        CelYoko = 0
        Call 経過表変動部分の画面作成(CelYoko)
    End If
    If OptionButton2.Value = True Then
        CelYoko = 1
        Call 経過表変動部分の画面作成(CelYoko)
    End If
    If OptionButton3.Value = True Then
        CelYoko = 2
        Call 経過表変動部分の画面作成(CelYoko)
    End If
    If OptionButton4.Value = True Then
        For CelYoko = 0 To 2
            Call 経過表変動部分の画面作成(CelYoko)
        Next
    End If
    If OptionButton5.Value = True Then
        Keika.Range("ED10") = ""
        Keika.Range("DC10") = ""
        Keika.Range("DM10") = ""
        Keika.Range("DT10") = ""
        Keika.Range("CN10") = "臨時"
                               
        ‘診断医欄クリアーコンテンツ
        Range("DL124").Select
        Selection.ClearContents
        
    &
nbsp;   ‘注射表示欄クリアーコンテンツ
        Range("S128:AU171").Select
        Selection.ClearContents
        
        ‘定時薬表示欄クリアーコンテンツ
        Range("CO128:EK171").Select
        Selection.ClearContents
        
        With Keika
            .PrintOut preview:=False
        End With
        Keika.Range("CN10") = ""
        
    End If
    
    
    MsgBox ("印刷が終わりました")
    KeikahyouMan.Show
End Sub
Private Sub 経過表変動部分の画面作成(Xpoint As Integer)
            ‘曜日
            UserNData2 = Touseki.Cells(CelTate, 33 + Xpoint)
            Keika.Range("ED10") = UserNData2
            ‘日付
            UserNData3 = Touseki.Cells(CelTate, 30 + Xpoint)
            Keika.Range("DC10") = Year(UserNData3)
            Keika.Range("DM10") = Month(UserNData3)
            Keika.Range("DT10") = Day(UserNData3)
                       
            CyusyaRow = 128
            
            ‘注射表示欄クリアーコンテンツ
            Range("S128:AU171").Select
            Selection.ClearContents
            
            ‘診断医欄消去
            Range("DL124").Select
            Selection.ClearContents
            
            ‘定時薬表示欄クリアーコンテンツ
            Range("CO128:EK171").Select
            Selection.ClearContents
          
            Keika.Cells(CyusyaRow, 19).Activate
            
            ‘エルシトニン
            If Touseki.Cells(CelTate, 70 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 70 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘キドミン
   &nbs
p;        If Touseki.Cells(CelTate, 71 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 71 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘グリマッケン
            If Touseki.Cells(CelTate, 72 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 72 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘キョウミノチン
            If Touseki.Cells(CelTate, 73 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 73 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘ノイロ
            If Touseki.Cells(CelTate, 74 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 74 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘アデラビン
            If Touseki.Cells(CelTate, 75 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 75 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘エポジン
            If Touseki.Cells(CelTate, 76 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 76 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘オキサロール
            If Touseki.Cells(CelTate, 77 + Xpoint * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 77 + Xpoint * 9)
                CyusyaRow = CyusyaRow + 4
            End If
            
            ‘リクセルorサブパックＢ
            If Touseki.Cells(CelTate, 78) <> "" Then
                Keika.Cells(168, 19) = Touseki.Cells(CelTate, 78 + Xpoint * 9)
            End If
            
            ‘ペンレス
            If Touseki.Cells(CelTate, 100) <> "" Then
                Keika.Range("DR168") = Touseki.Cells(CelTate, 100 + Xpoint)
            End If
            
            If Touseki.Cells(CelTate, 132) = "院外処方" Then
            
                ‘If Xpoint <> 2 Then ‘定時薬
                
                    Kotae = 空欄か空欄ではないか､それが問題だ(CelTate, 133 + Xpoint * 12)
                    
                    If Kotae = False Then ‘空欄ではない時の処理
                        ‘診断医記入
                        UserData = Touseki.Cells(CelTate, 131).Value
                        Keika.Range("DL124") = UserData
                    Else
                        
                    End If
                    
                    ‘定時薬記入
                    UserData = Touseki.Cells(CelTate, 133 + Xpoint * 12).Value
                    Keika.Range("CO128") = UserData
                    UserData = Touseki.Cells(CelTate, 134 + Xpoint * 12).Value
                    Keika.Range("CO132") = UserData
                    UserData = Touseki.Cells(CelTate, 135 + Xpoint * 12).Value
                    Keika.Range("CO136") = UserData
                    UserData = Touseki.Cells(CelTate, 136 + Xpoint * 12).Value
                    Keika.Range("CO140") = UserData
                    UserData = Touseki.Cells(CelTate, 137 + Xpoint * 12).Value
                    Keika.Range("CO144") = UserData
                    UserData = Touseki.Cells(CelTate, 138 + Xpoint * 12).Value
                    Keika.Range("CO148") = UserData
                    UserData = Touseki.Cells(CelTate, 139 + Xpoint * 12).Value
                    Keika.Range("CO152") = UserData
                    UserData = Touseki.Cells(CelTate, 140 + Xpoint * 12).Value
                    Keika.Range("CO156") = UserData
      &
nbsp;             UserData = Touseki.Cells(CelTate, 141 + Xpoint * 12).Value
                    Keika.Range("CO160") = UserData
                    UserData = Touseki.Cells(CelTate, 142 + Xpoint * 12).Value
                    Keika.Range("CO164") = UserData
                    UserData = Touseki.Cells(CelTate, 143 + Xpoint * 12).Value
                    Keika.Range("CO168") = UserData
                    ‘UserData = Touseki.Cells(CelTate, 144 + Xpoint * 12).Value
                    ‘Keika.Range("a1") = UserData
                    
                ‘End If
                
            End If
        
            Application.Wait (Now + TimeValue("00:00:07"))

            With Keika
                .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


Private Sub CommandButton4_Click()
    Unload KeikahyouMan
    AutoMnSele2.Show
End Sub

Private Sub ListBox1_Click()
    Kensaku = KeikahyouMan.ListBox1.Text
    Set Touseki = Worksheets("透析患者リスト")
    MaxRows = Touseki.UsedRange.Rows.Count
    WorkArea = "B1:B" & MaxRows
    
    
    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)
    CelTate = CellAddress
    
    ‘KeikahyouMan.OptionButton1.Value = False
    ‘KeikahyouMan.OptionButton2.Value = False
 &nb
sp;  ‘KeikahyouMan.OptionButton3.Value = False
    KeikahyouMan.OptionButton4.Value = True
    
    UserData = Touseki.Cells(CelTate, 2).Value
    KeikahyouMan.Label3.Caption = UserData
    ‘UserData = Touseki.Cells(CelTate, 33).Value
    ‘KeikahyouMan.OptionButton1.Caption = UserData
    
    
    ‘印刷曜日選択オプションボタンのラベル付けと表示、非表示判断
    UserData = Touseki.Cells(CelTate, 2).Value
    If UserData = "" Then
        KeikahyouMan.OptionButton1.Visible = False
        KeikahyouMan.OptionButton2.Visible = False
        KeikahyouMan.OptionButton3.Visible = False
        KeikahyouMan.OptionButton4.Visible = False
        CommandButton3.Visible = False
    Else
        KeikahyouMan.OptionButton1.Visible = True
        UserData = Touseki.Cells(CelTate, 33).Value
        KeikahyouMan.OptionButton1.Caption = UserData
        
        KeikahyouMan.OptionButton2.Visible = True
        UserData = Touseki.Cells(CelTate, 34).Value
        KeikahyouMan.OptionButton2.Caption = UserData
        
        KeikahyouMan.OptionButton3.Visible = True
        UserData = Touseki.Cells(CelTate, 35).Value
        KeikahyouMan.OptionButton3.Caption = UserData
        
        ‘KeikahyouMan.OptionButton4.Visible = True
        ‘UserData = "一週間分"
        ‘KeikahyouMan.OptionButton4.Caption = UserData
        
        ‘KeikahyouMan.OptionButton5.Visible = True
        ‘UserData = "臨時透析"
        ‘KeikahyouMan.OptionButton5.Caption = UserData
    End If
    
End Sub

Private Sub OptionButton1_Click()
    UserData = Touseki.Cells(CelTate, 33).Value
    KeikahyouMan.Label2.Caption = UserData
    
End Sub

Private Sub OptionButton2_Click()
    UserData = Touseki.Cells(CelTate, 34).Value
    KeikahyouMan.Label2.Caption = UserData
    
End Sub

Private Sub OptionButton3_Click()
    UserData = Touseki.Cells(CelTate, 35).Value
    KeikahyouMan.Label2.Caption = UserData
    
End Sub

Private Sub OptionButton4_Click()
    UserData = "一週間分"
    KeikahyouMan.Label2.Caption = UserData
End Sub

Private Sub OptionButton5_Click()
    UserData = "臨時透析用"
    KeikahyouMan.Label2.Caption = UserData
End Sub