FC2ブログ
ご訪問ありがとうございます。パソコンを使っていて試行錯誤したことを記載した備忘録です。
患者さんの氏名や生年月日、血液型などを修正するためのフォームです。

このフォームはめったに使うことはありません。どちらかというと修正目的というよりは、閲覧目的が主な作成理由です。緊急時などにすぐさま血液型や生年月日を見ることができるようにということです。 修正ももちろんできますが、誤入力が発覚したときのみです。

患者さん個別情報フォーム
 


Dim Touseki As Object
Dim Tcolor As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer

Private Type MemberData
    IDBango As String
    Simei1 As String
    Simei4 As String
    SeiBetsu As String
    Tanjyobi As Date
    Nenrei As String
    KetsuGata As String
    RH As String
    HenkoSwitch As Boolean
End Type

Dim OldMember() As MemberData
Dim YMD(2, 3) As String
Dim ChangeSwitch As Boolean
Dim l As Integer
Dim HizukeErrSwitch As Boolean


Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
    ChangeSwitch = False
   
    透析条件テンプ作成
    Call Member
    氏名box

End Sub
Private Sub Member()
    ReDim OldMember(MaxRows)
   
    l = 0

        For i = 3 To MaxRows
           
            With OldMember(l)
                .IDBango = Touseki.Cells(i, 1)
                .Simei4 = Touseki.Cells(i, 2)
                .Simei1 = Touseki.Cells(i, 3)
                .SeiBetsu = Touseki.Cells(i, 4)
                .Tanjyobi = CDate(Touseki.Cells(i, 5))
                .Nenrei = Touseki.Cells(i, 6)
                .KetsuGata = Touseki.Cells(i, 7)
                .RH = Touseki.Cells(i, 8)
       
                .HenkoSwitch = False
            End With
           
            l = l + 1
        Next
        Maxl = l
End Sub


Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    ListBox1.Clear
    ListIdx = 0
   
        l = 0
        Do '
            Do While OldMember(l).Simei1 <> "" '.iro = 3
                KojinJohoFix.ListBox1.AddItem (OldMember(l).Simei1)
                l = l + 1
            Loop
            l = l + 1
        Loop While l < Maxl
       
        With KojinJohoFix.ListBox1
            .ListIndex = 0 'ListIdx
        End With
   
End Sub


Private Sub ListBox1_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    ListIdx = ListBox1.ListIndex
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub


Private Sub CxBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("転送せずに終了します。それでよければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload KojinJohoFix
        AboutForm.Show
    End If
End Sub

Private Sub ExitBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    If HizukeErrSwitch = False Then
        Rtn = MsgBox("今まで行った変更を、ワークシートへ転送します。よろしければOKを押してください。", vbOKCancel)
        If Rtn = vbOK Then
            変更を保存して終了
            Unload KojinJohoFix
            AboutForm.Show
        End If
       
    End If
    HizukeErrSwitch = False
End Sub


Private Sub CheckBox1_Change()

    If CheckBox1.Value = True Then
        TextBox1.Enabled = True
        TextBox2.Enabled = True
        TextBox3.Enabled = True
        TextBox4.Enabled = True
        TextBox5.Enabled = True
        ComboBox2.Enabled = True
        ComboBox3.Enabled = True
        ComboBox4.Enabled = True
        ComboBox5.Enabled = True
        ComboBox6.Enabled = True
    Else
        TextBox1.Enabled = False
        TextBox2.Enabled = False
        TextBox3.Enabled = False
        TextBox4.Enabled = False
        TextBox5.Enabled = False
        ComboBox2.Enabled = False
        ComboBox3.Enabled = False
        ComboBox4.Enabled = False
        ComboBox5.Enabled = False
        ComboBox6.Enabled = False
    End If
       
End Sub


Private Sub CommandButton1_Click()
    Call 個別へ表示(ByVal l)
End Sub

Private Sub CommandButton2_Click()
    Dim Namae As String
    Dim MeNamae As Object
    Namae = TextBox19.Text
    Set MeNamae = KojinJohoFix
    Call 検索(Namae, MeNamae)
End Sub
Private Sub CommandButton3_Click()
    氏名box
End Sub


Sub 個別へ表示(ByVal l As Integer)
   
    With OldMember(l)
        TextBox1.Text = .IDBango
        TextBox2.Text = .Simei4
        TextBox3.Text = .Simei1
        ComboBox2.Text = .SeiBetsu
       
        If .Tanjyobi <> "0:00:00" Then
            YMD(0, 0) = Year(.Tanjyobi)
            YMD(0, 1) = Month(.Tanjyobi)
            YMD(0, 2) = Day(.Tanjyobi)
        Else
            YMD(0, 0) = "*"
            YMD(0, 1) = "*"
            YMD(0, 2) = "*"
        End If
       
        On Error GoTo HizukeError
        ComboBox3.Text = YMD(0, 0)
        ComboBox4.Text = YMD(0, 1)
        ComboBox5.Text = YMD(0, 2)
       
        Label29.Caption = .Nenrei
        TextBox4.Text = .KetsuGata
        TextBox5.Text = .RH
       
    End With
    ChangeSwitch = False
    Exit Sub
   
HizukeError:
    MsgBox ("生年月日の日付がテンプレートで準備されている日付を超えています")
    MsgBox ("いったん保存してから、フォームを閉じてこのブック内のワークシート(テンプレート集)に必要な日付を追加してください")
   
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer
    Dim kensakuSu As Integer
   
    kensakuSu = 0
    For l = 0 To Maxl
        If OldMember(l).Simei1 = Namae Then
           
            kensakuSu = kensakuSu + 1
            If kensakuSu > 1 Then
                MsgBox ("透析患者リストの中に、同名で2件以上のデータがあります。不要なデータを削除して下さい。")
                Exit For
            End If
            Kensaku = l
        End If
    Next

End Function


Sub 保存忘れ防止装置()
    If ChangeSwitch = True Then
        ChangeSwitch = False
        個別変更内容チェック
        Call 透析情報変数の更新(ByVal l)
    End If
End Sub

Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
   
    l = 0
   
    KojinJohoFix.Hide
   
    For i = 3 To MaxRows
        With OldMember(l)
            If .HenkoSwitch = True Then
           
                'ID番号の転送
                Touseki.Cells(i, 1).Activate
                Touseki.Cells(i, 1) = .IDBango
                '名前(漢字)の転送
                Touseki.Cells(i, 2).Activate
                Touseki.Cells(i, 2) = .Simei4
                '名前(カナ)転送
                Touseki.Cells(i, 3).Activate
                Touseki.Cells(i, 3) = .Simei1
                '性別の転送
                Touseki.Cells(i, 4).Activate
                Touseki.Cells(i, 4) = .SeiBetsu
                '生年月日の転送
                Touseki.Cells(i, 5).Activate
                If .Tanjyobi <> "0:00:00" Then
                    Touseki.Cells(i, 5) = .Tanjyobi
                Else
                    Touseki.Cells(i, 5) = ""
                End If
                '血液型の転送
                Touseki.Cells(i, 7).Activate
                Touseki.Cells(i, 7) = .KetsuGata
                'RH(血液型)の転送
                Touseki.Cells(i, 8).Activate
                Touseki.Cells(i, 8) = .RH
                   
            End If
            l = l + 1
        End With
    Next
   
    MsgBox ("データの転送が終了しました")
   
End Sub

Sub 透析情報変数の更新(ByVal l As Integer)

    With OldMember(l)
        .HenkoSwitch = True
        .IDBango = TextBox1.Text
        .Simei4 = TextBox2.Text
        .Simei1 = TextBox3.Text
        .SeiBetsu = ComboBox2.Text
       
        '生年月日更新
       
        '生年月日に”*”が入力されている場合
        If ComboBox3.Text <> "*" Then
            YMD(0, 0) = ComboBox3.Text
        Else
            YMD(0, 0) = "1899"
        End If
        If ComboBox4.Text <> "*" Then
            YMD(0, 1) = ComboBox4.Text
        Else
            YMD(0, 1) = "12"
        End If
        If ComboBox5.Text <> "*" Then
            YMD(0, 2) = ComboBox5.Text
        Else
            YMD(0, 2) = "30"
        End If
       
        '生年月日に"(空欄)"が入力されている場合
        'If ComboBox3.Text <> "" Then
        '    YMD(0, 0) = ComboBox3.Text
        'Else
        '    YMD(0, 0) = "1899"
        'End If
        'If ComboBox4.Text <> "" Then
        '    YMD(0, 1) = ComboBox4.Text
        'Else
        '    YMD(0, 1) = "12"
        'End If
        'If ComboBox5.Text <> "" Then
        '    YMD(0, 2) = ComboBox5.Text
        'Else
        '    YMD(0, 2) = "30"
        'End If
        On Error GoTo trap
        .Tanjyobi = DateSerial(CInt(YMD(0, 0)), CInt(YMD(0, 1)), CInt(YMD(0, 2)))
       
        .KetsuGata = TextBox4.Text
        .RH = TextBox5.Text
       
        Exit Sub
       
trap:
        MsgBox "生年月日の年・月・日のどれかの入力が間違っています。半角の数字を入力して下さい"
        HizukeErrSwitch = True
    End With
End Sub
       

Sub 透析条件テンプ作成()
    Dim Tempulist As Object
    Dim Tate As Integer
    Dim Yoko As Integer
   
    Set Tempulist = Worksheets("テンプレート集")
   
    '男女
    Tate = 3
    Yoko = 1
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox2.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '西暦
    Tate = 3
    Yoko = 2
    ComboBox3.AddItem ("*")
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox3.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '和暦
    Tate = 3
    Yoko = 3
    ComboBox6.AddItem ("*")
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox6.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '生年月日の月・日
    ComboBox4.AddItem ("*")
    For i = 1 To 12
        ComboBox4.AddItem (i)
    Next
   
    ComboBox5.AddItem ("*")
    For i = 1 To 31
        ComboBox5.AddItem (i)
    Next
End Sub
Private Sub OptionButton11_Click()
    ChangeSwitch = True
    Tcolor = 3
End Sub

Private Sub OptionButton12_Click()
    ChangeSwitch = True
    Tcolor = 5
End Sub

Private Sub OptionButton13_Click()
    ChangeSwitch = True
    Tcolor = 6
End Sub

Private Sub OptionButton14_Click()
    ChangeSwitch = True
    Tcolor = 4
End Sub

Private Sub OptionButton15_Click()
    ChangeSwitch = True
    Tcolor = 2
End Sub



Private Sub ComboBox10_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox11_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox12_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox13_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox14_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox15_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox16_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox2_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox3_Change()
    ChangeSwitch = True
    ComboBox6.ListIndex = ComboBox3.ListIndex
    If ComboBox3.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox5.Text = "*"
        ComboBox6.Text = "*"
    End If
End Sub

Private Sub ComboBox4_Change()
    ChangeSwitch = True
    If ComboBox4.Text = "*" Then
        ComboBox3.Text = "*"
        ComboBox5.Text = "*"
        ComboBox6.Text = "*"
    End If
End Sub

Private Sub ComboBox5_Change()
    ChangeSwitch = True
    If ComboBox5.Text = "*" Then
        ComboBox3.Text = "*"
        ComboBox4.Text = "*"
        ComboBox6.Text = "*"
    End If
End Sub

Private Sub ComboBox6_Change()

    ChangeSwitch = True
    ComboBox3.ListIndex = ComboBox6.ListIndex
    If ComboBox6.Text = "*" Then
        ComboBox3.Text = "*"
        ComboBox4.Text = "*"
        ComboBox5.Text = "*"
    End If
End Sub

Private Sub ComboBox7_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox8_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox9_Change()
    ChangeSwitch = True
End Sub

Private Sub TextBox1_Change()
    ChangeSwitch = True
End Sub

Private Sub TextBox2_Change()
    ChangeSwitch = True
End Sub

Private Sub TextBox3_Change()
    ChangeSwitch = True
End Sub

Private Sub TextBox4_Change()
    ChangeSwitch = True
End Sub

Private Sub TextBox5_Change()
    ChangeSwitch = True
End Sub
Private Sub 個別変更内容チェック()

    '日付欄のいずれかが”*”の場合
    If ComboBox3.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox5.Text = "*"
    End If

    If ComboBox4.Text = "*" Then
        ComboBox3.Text = "*"
        ComboBox5.Text = "*"
    End If

    If ComboBox5.Text = "*" Then
        ComboBox3.Text = "*"
        ComboBox4.Text = "*"
    End If
   
    '日付欄のいずれかが”(空欄)”の場合
    'If ComboBox3.Text = "" Then
    '    ComboBox4.Text = ""
    '    ComboBox5.Text = ""
    'End If

    'If ComboBox4.Text = "" Then
    '    ComboBox3.Text = ""
    '    ComboBox5.Text = ""
    'End If

    'If ComboBox5.Text = "" Then
    '    ComboBox3.Text = ""
    '    ComboBox4.Text = ""
    'End If
End Sub
  


追記を閉じる▲
スポンサーサイト




【2008/03/12 23:02】 | エクセルVBAで作った透析データベース
トラックバック(0) |
処方箋をお一人分ずつ印刷するためのマクロです。

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

処方箋個別印刷フォーム
 


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(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("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:=xlNext, 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


追記を閉じる▲

【2008/03/12 22:59】 | エクセルVBAで作った透析データベース
トラックバック(0) |
1週間分の処方箋を自動で印刷するためのフォームです。

 処方箋自動印刷フォーム



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


追記を閉じる▲

【2008/03/12 22:56】 | エクセルVBAで作った透析データベース
トラックバック(0) |

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

経過表個別印刷フォーム

 


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
        
        '注射表示欄クリアーコンテンツ
        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
            
            'キドミン
            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サブパックB
            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
                    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
    '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


追記を閉じる▲

【2008/03/12 22:52】 | エクセルVBAで作った透析データベース
トラックバック(0) |
今回のマクロは、透析の経過表を自動印刷するためのマクロです。

透析では1日に一人の患者さんに1枚の経過表を使います。経過表とは文字通り透析の経過を書き記した物です。
 そのため毎日の決まった事柄はあらかじめ印刷してあった方が手間が省けて便利です。それは氏名とか血液型、年齢、日付、その患者さんが使う注射薬などです。 これぞデータベースを使う最も意義のあるところだと思います。
経過表自動印刷フォーム
 
透析のクール(時間と曜日帯)によって色分けがしてあります。このボタンを押すことで、その曜日・時間帯の患者さんの経過表を1週間分まとめて印刷することができます。
Dim Touseki As Object
Dim Keika As Object
Dim RowPos As Integer
Dim iro As Integer
Dim MaxRows As Long
Dim CelNo As String
Dim UserData As String
Dim UserNData1 As Date
Dim UserNData2 As String
Dim UserNData3 As Date
Dim UserNData4 As Object
Dim CelYoko As Integer
Dim Hiduke(3) As String
Dim CyusyaRow As Integer
Dim Tcolor As Byte


Private Sub UserForm_Initialize()
   
    RowPos = 3
    Set Touseki = Worksheets("透析患者リスト")
    Set Keika = Worksheets("平成16年度版経過表")
    MaxRows = Touseki.UsedRange.Rows.Count
   
    Keika.Activate
End Sub



Private Sub 経過表印刷ルーチン() '経過表印刷ルーチン準備部
    KeikahyouAuto.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, 2) = "" Then
                Exit Do
            End If
            For i = 0 To 2
                Hiduke(i) = Touseki.Cells(RowPos, 30 + i)
            Next
            Call Insatsu_Keika(ByVal RowPos)
            RowPos = RowPos + 1
        Loop
        RowPos = RowPos + 1
    Loop While RowPos <= MaxRows
   
    Unload KeikahyouAuto
End Sub
Private Sub CommandButton1_Click()
'赤
    Tcolor = 3
    経過表印刷ルーチン
End Sub
Private Sub CommandButton2_Click()
'青
    Tcolor = 5
    経過表印刷ルーチン
End Sub
Private Sub CommandButton3_Click()
'黄色
    Tcolor = 6
    経過表印刷ルーチン
End Sub

Private Sub CommandButton4_Click()
'緑
    Tcolor = 4
    経過表印刷ルーチン
End Sub

Private Sub CommandButton5_Click()
    Unload KeikahyouAuto
    AutoMnSele2.Show
End Sub


Sub Insatsu_Keika(ByVal CelTate As Integer) '経過表印刷ルーチン実行部

    Set Touseki = Worksheets("透析患者リスト")
    Set Keika = Worksheets("平成16年度版経過表")
   
    Keika.Activate
   
    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 CelYoko = 0 To 2
        If Hiduke(CelYoko) <> "" Then
            '曜日
            UserNData2 = Touseki.Cells(CelTate, 33 + CelYoko)
            Keika.Range("ED10") = UserNData2
            '日付
            UserNData3 = Touseki.Cells(CelTate, 30 + CelYoko)
            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 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 70 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'キドミン
            If Touseki.Cells(CelTate, 71 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 71 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'グリマッケン
            If Touseki.Cells(CelTate, 72 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 72 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'キョウミノチン
            If Touseki.Cells(CelTate, 73 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 73 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'ノイロ
            If Touseki.Cells(CelTate, 74 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 74 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'アデラビン
            If Touseki.Cells(CelTate, 75 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 75 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'エポジン
            If Touseki.Cells(CelTate, 76 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 76 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'オキサロール
            If Touseki.Cells(CelTate, 77 + CelYoko * 9) <> "" Then
                Keika.Cells(CyusyaRow, 19) = Touseki.Cells(CelTate, 77 + CelYoko * 9)
                CyusyaRow = CyusyaRow + 4
            End If
           
            'リクセルorサブパックB
            If Touseki.Cells(CelTate, 78) <> "" Then
                Keika.Cells(168, 19) = Touseki.Cells(CelTate, 78 + CelYoko * 9)
            End If
           
            'ペンレス
            If Touseki.Cells(CelTate, 100) <> "" Then
                Keika.Range("DR168") = Touseki.Cells(CelTate, 100 + CelYoko)
            End If
           
            If Touseki.Cells(CelTate, 132) = "院外処方" Then
           
                'If CelYoko <> 2 Then '定時薬
                   
                    Kotae = 空欄か空欄ではないか、それが問題だ(CelTate, 133 + CelYoko * 12)
                   
                    If Kotae = False Then '空欄ではない時の処理
                        '診断医記入
                        UserData = Touseki.Cells(CelTate, 131).Value
                        Keika.Range("DL124") = UserData
                    'Else
                       
                    'End If
                   
                   
                    '定時薬記入
                    UserData = Touseki.Cells(CelTate, 133 + CelYoko * 12).Value
                    Keika.Range("CO128") = UserData
                    UserData = Touseki.Cells(CelTate, 134 + CelYoko * 12).Value
                    Keika.Range("CO132") = UserData
                    UserData = Touseki.Cells(CelTate, 135 + CelYoko * 12).Value
                    Keika.Range("CO136") = UserData
                    UserData = Touseki.Cells(CelTate, 136 + CelYoko * 12).Value
                    Keika.Range("CO140") = UserData
                    UserData = Touseki.Cells(CelTate, 137 + CelYoko * 12).Value
                    Keika.Range("CO144") = UserData
                    UserData = Touseki.Cells(CelTate, 138 + CelYoko * 12).Value
                    Keika.Range("CO148") = UserData
                    UserData = Touseki.Cells(CelTate, 139 + CelYoko * 12).Value
                    Keika.Range("CO152") = UserData
                    UserData = Touseki.Cells(CelTate, 140 + CelYoko * 12).Value
                    Keika.Range("CO156") = UserData
                    UserData = Touseki.Cells(CelTate, 141 + CelYoko * 12).Value
                    Keika.Range("CO160") = UserData
                    UserData = Touseki.Cells(CelTate, 142 + CelYoko * 12).Value
                    Keika.Range("CO164") = UserData
                    UserData = Touseki.Cells(CelTate, 143 + CelYoko * 12).Value
                    Keika.Range("CO168") = UserData
                   
                    End If
                'End If
            End If
            Application.Wait (Now + TimeValue("0:00:05"))
            With Keika
                .PrintOut preview:=False
            End With
           
        End If
    Next
                       
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


追記を閉じる▲

【2008/03/12 22:46】 | エクセルVBAで作った透析データベース
トラックバック(0) |
各患者さんの保険番号を管理するためのフォームです。

保険番号は処方箋を印刷するときに使用します。

フォームを使う訳は、エクセルのシートで該当箇所を探す手間が省けること、誤入力を減らせること、そしてコンボボックスで選択して入れられることから入力時間の短縮が見込めるからです。

 保険番号フォーム
Dim Touseki As Object
Dim iro As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer

Private Type MemberData
    Simei1 As String
    Simei4 As String
    Hoken1 As String
    Hoken2 As String
    Hoken3 As String
    Hoken4 As String
    Hoken5 As String
    Hoken6 As String
    iro As Integer
End Type
Dim OldMember() As MemberData
Dim HenkoSwitch() As Boolean

Dim l As Integer




Private Sub CommandButton2_Click()
    Dim Namae As String
    Dim MeNamae As Object
   
    OptionButton1.Value = False
    OptionButton2.Value = False
   
    Namae = TextBox4.Text
    Set MeNamae = Hoken
    Call 検索(Namae, MeNamae)
End Sub

Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
   
    Call Member
    OptionButton1.Value = True
    保険番号テンプ作成
End Sub
Private Sub Member()
    ReDim HenkoSwitch(MaxRows)
    ReDim OldMember(MaxRows)
   
    l = 0

    With Touseki
        For i = 2 To MaxRows
           
            With OldMember(l)
                .Simei1 = Touseki.Cells(i, 3)
                .Simei4 = Touseki.Cells(i, 2)
               
                .Hoken1 = Touseki.Cells(i, 20)
                .Hoken2 = Touseki.Cells(i, 21)
                .Hoken3 = Touseki.Cells(i, 22)
                .Hoken4 = Touseki.Cells(i, 23)
                .Hoken5 = Touseki.Cells(i, 24)
                .Hoken6 = Touseki.Cells(i, 25)
               
                .iro = Touseki.Cells(i, 1).Interior.ColorIndex
            End With
            HenkoSwitch(l) = False
               
            l = l + 1
        Next
        Maxl = l
    End With
End Sub
Private Sub Optionbutton1_Change()
    If OptionButton1.Value = True Then
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub Optionbutton2_Change()
    If OptionButton2.Value = True Then
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    Hoken.ListBox1.Clear
    ListIdx = 0
   
    If OptionButton1.Value = True Then

        l = 0
        Do '赤(月水金AM)の処理
            iro = OldMember(l).iro
            Do While iro = 3
                If OldMember(l).iro <> 3 Then
                    Exit Do
                End If
       
                Hoken.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '青(月水金PM)の処理
            iro = OldMember(l).iro
            Do While iro = 5
                If OldMember(l).iro <> 5 Then
                    Exit Do
                End If
       
                Hoken.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        With Hoken.ListBox1
            .ListIndex = ListIdx
        End With
    End If
   
    If OptionButton2.Value = True Then
        l = 0
        Do '黄(火木土AM)の処理
            iro = OldMember(l).iro
            Do While iro = 6
                If OldMember(l).iro <> 6 Then
                    Exit Do
                End If
       
                Hoken.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '緑(火木土PM)の処理
            iro = OldMember(l).iro
            Do While iro = 4
                If OldMember(l).iro <> 4 Then
                    Exit Do
                End If
       
                Hoken.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
   
        With Hoken.ListBox1
            .ListIndex = ListIdx
        End With
       
    End If
End Sub
Private Sub ListBox1_Click()
    ListIdx = ListBox1.ListIndex
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub
Sub 個別へ表示(ByVal l As Integer)
   
    Hoken.ComboBox1.Text = OldMember(l).Hoken1
    Hoken.TextBox1.Text = OldMember(l).Hoken2
    Hoken.ComboBox2.Text = OldMember(l).Hoken3
    Hoken.TextBox2.Text = OldMember(l).Hoken4
    Hoken.ComboBox3.Text = OldMember(l).Hoken5
    Hoken.TextBox3.Text = OldMember(l).Hoken6
   
    Hoken.Label8.Caption = OldMember(l).Simei4
    'Call 曜日更新(ByVal l)
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer

    For l = 0 To Maxl
        If OldMember(l).Simei1 = Namae Then
            Kensaku = l
            Exit For
        End If
    Next
           
End Function


Private Sub CxBtn_Click()
    Rtn = MsgBox("転送せずに終了します。それでよければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload Hoken
        AboutForm.Show
    End If
End Sub

Private Sub ExitBtn_Click()
    Rtn = MsgBox("今まで行った変更を、ワークシートへ転送します。よろしければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        変更を保存して終了
        Unload Hoken
        AboutForm.Show
    End If
   
End Sub
Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
   
    l = 0
   
    Hoken.Hide
   
    For i = 2 To MaxRows
        If HenkoSwitch(l) = True Then
       
            With OldMember(l)
            '名前転送
                Touseki.Cells(i, 3).Activate
                Touseki.Cells(i, 3) = .Simei1
                Touseki.Cells(i, 2).Activate
                Touseki.Cells(i, 2) = .Simei4
               
            '保険番号の転送
                Touseki.Cells(i, 20).Activate
                Touseki.Cells(i, 20) = .Hoken1
           
                Touseki.Cells(i, 21).Activate
                Touseki.Cells(i, 21) = .Hoken2
           
                Touseki.Cells(i, 22).Activate
                Touseki.Cells(i, 22) = .Hoken3
           
                Touseki.Cells(i, 23).Activate
                Touseki.Cells(i, 23) = .Hoken4
           
                Touseki.Cells(i, 24).Activate
                Touseki.Cells(i, 24) = .Hoken5
           
                Touseki.Cells(i, 25).Activate
                Touseki.Cells(i, 25) = .Hoken6
                                  
            End With
        End If
        l = l + 1
    Next
    MsgBox ("データの転送が終了しました")
End Sub

Private Sub InputBtn_Click()
    Call 文字整列と保険番号変数の更新(ByVal l)
   
    Call 氏名box
End Sub

Sub 文字整列と保険番号変数の更新(ByVal l As Integer)
    Dim MojiRetsu As String
    HenkoSwitch(l) = True
       
    If ComboBox1.Text <> "" Then
        MojiRetsu = Trim(ComboBox1.Text)
        OldMember(l).Hoken1 = SeiRetsu(ByVal MojiRetsu)
    Else
        OldMember(l).Hoken1 = ""
    End If
   
    If TextBox1.Text <> "" Then
        MojiRetsu = Trim(TextBox1.Text)
        OldMember(l).Hoken2 = MojiRetsu
    Else
        OldMember(l).Hoken2 = ""
    End If
   
    If ComboBox2.Text <> "" Then
        MojiRetsu = Trim(ComboBox2.Text)
        OldMember(l).Hoken3 = SeiRetsu(ByVal MojiRetsu)
    Else
        OldMember(l).Hoken3 = ""
    End If
   
    If TextBox2.Text <> "" Then
        MojiRetsu = Trim(TextBox2.Text)
        OldMember(l).Hoken4 = SeiRetsu(ByVal MojiRetsu)
    Else
        OldMember(l).Hoken4 = ""
    End If
   
    If ComboBox3.Text <> "" Then
        MojiRetsu = Trim(ComboBox3.Text)
        OldMember(l).Hoken5 = SeiRetsu(ByVal MojiRetsu)
    Else
        OldMember(l).Hoken5 = ""
    End If
   
    If TextBox3.Text <> "" Then
        MojiRetsu = Trim(TextBox3.Text)
        'Call SeiRetsu(ByVal MojiRetsu)
        OldMember(l).Hoken6 = SeiRetsu(ByVal MojiRetsu)
    Else
        OldMember(l).Hoken6 = ""
    End If
End Sub
       
   
Function SeiRetsu(ByVal MojiRetsu As String) As String
    Dim K As Byte
    Dim KariMoji As String
    Dim Moji() As String
   
    K = 0
    StrCount = Len(MojiRetsu)
    For i = 1 To StrCount
        KariMoji = Left(MojiRetsu, i)
        KariMoji = Right(KariMoji, 1)
        If KariMoji <> " " Then
            If KariMoji <> " " Then
                ReDim Preserve Moji(K + 1)
                Moji(K) = KariMoji
                K = K + 1
               
            End If
        End If
    Next
    SeiRetsu = Trim(Join(Moji, "   "))

End Function

Sub 保険番号テンプ作成()
  
    ComboBox1.AddItem ("2   1   3   6")
    ComboBox1.AddItem ("1   3   8   2   3   0")
   
    ComboBox2.AddItem ("8   2   1   3   8   0   0   9")
    ComboBox2.AddItem ("2   7   1   3   8   2   3   9")
   
    ComboBox3.AddItem ("8   2   1   3   8   0   0   9")
 '       ComboBox6.AddItem ("*")
 '       ComboBox9.AddItem ("*")
End Sub


追記を閉じる▲

【2008/03/12 22:41】 | エクセルVBAで作った透析データベース
トラックバック(0) |

これは患者さんの定時薬の編集を行なう画面です。

中央のタブ切り替えのところに「処方①」「処方②」「処方③」とありますがこれを切り替えることで処方箋を別の日付で出すことができます。

週1枚で処方箋が足りる方の場合は「処方②」「処方③」をまったくの空欄にしておけば印刷のときに1枚しか出てきません。 患者さんによって処方箋の数は代わりますのでこのようにしました。

残念ながらこのフォームでは4枚以上出すことは想定しておりません。


定時薬変更フォーム


元々このフォームは注射薬のように入力欄を3列に並べてありました。

よりフォームをコンパクトにするためと文字入力欄を広くするためにタブ切り替えに変えました。 コードは以下の通りです。(続きを読むをクリックしてください)


'Option Explicit

Dim Touseki As Object
Dim iro As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer

Private Type MemberData
    Simei1 As String
    Simei4 As String
    YakuZai(3, 12) As String
    AutoInsatsu As Boolean
    Yobi(3) As String
    iro As Integer
    HenkoSwitch As Boolean 'データ変更済み患者様特定用フラグ
    ShindanI As String '診断医
End Type
Dim OldMember() As MemberData
Dim ChangeSwitch As Boolean 'フォーム内容変更検知フラグ
Dim l As Integer
Dim Syoho(1, 11) As Integer
Dim Ishi As Integer
Dim MarkIngai As Integer



Private Sub Label7_Click()

End Sub

Private Sub MultiPage1_Change()

End Sub

Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
    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
    Ishi = 131
    MarkIngai = 132
   
    ChangeSwitch = False
    With ComboBox37
        .AddItem ("しない")
        .AddItem ("する")
    End With
   
    Call Member
    OptionButton1.Value = True
    定時薬テンプ作成
       
End Sub

Private Sub Member()
    ReDim OldMember(MaxRows)
    Dim K As Byte
    Dim i As Integer
   
    With Touseki
        For i = 3 To MaxRows
            l = i - 3
            With OldMember(l)
                .Simei1 = Touseki.Cells(i, 3)
                .Simei4 = Touseki.Cells(i, 2)
                .ShindanI = Touseki.Cells(i, Ishi)
                For K = 0 To 2
                    .YakuZai(K, 0) = Touseki.Cells(i, Syoho(0, 0) + K * 12) '処方①
                    .YakuZai(K, 1) = Touseki.Cells(i, Syoho(0, 1) + K * 12) '
                    .YakuZai(K, 2) = Touseki.Cells(i, Syoho(0, 2) + K * 12) '
                    .YakuZai(K, 3) = Touseki.Cells(i, Syoho(0, 3) + K * 12) '
                    .YakuZai(K, 4) = Touseki.Cells(i, Syoho(0, 4) + K * 12) '
                    .YakuZai(K, 5) = Touseki.Cells(i, Syoho(0, 5) + K * 12) '
                    .YakuZai(K, 6) = Touseki.Cells(i, Syoho(0, 6) + K * 12) '
                    .YakuZai(K, 7) = Touseki.Cells(i, Syoho(0, 7) + K * 12) '
                    .YakuZai(K, 8) = Touseki.Cells(i, Syoho(0, 8) + K * 12) '
                    .YakuZai(K, 9) = Touseki.Cells(i, Syoho(0, 9) + K * 12) '
                    .YakuZai(K, 10) = Touseki.Cells(i, Syoho(0, 10) + K * 12) '処方⑪
                   
                   
                    .Yobi(K) = Touseki.Cells(i, 33 + K)
                Next
               
                If Touseki.Cells(i, MarkIngai) <> "" Then
                    .AutoInsatsu = True
                Else
                    .AutoInsatsu = False
                End If
                .HenkoSwitch = False
                .iro = Touseki.Cells(i, 1).Interior.ColorIndex
            End With
               
        Next
        Maxl = l
    End With
End Sub
Private Sub Optionbutton1_Change()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    If OptionButton1.Value = True Then
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub Optionbutton2_Change()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    If OptionButton2.Value = True Then
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    TeijiYaku.ListBox1.Clear
    ListIdx = 0
    Maxl = 0
   
    If OptionButton1.Value = True Then

        l = 0
        Do '赤(月水金AM)の処理
            iro = OldMember(l).iro
            Do While iro = 3
                If OldMember(l).iro <> 3 Then
                    Exit Do
                End If
       
                TeijiYaku.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
                Maxl = Maxl + 1
            Loop
            l = l + 1
        Loop While l < MaxRows 'Maxl
       
        l = 0
        Do '青(月水金PM)の処理
            iro = OldMember(l).iro
            Do While iro = 5
                If OldMember(l).iro <> 5 Then
                    Exit Do
                End If
       
                TeijiYaku.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
                Maxl = Maxl + 1
            Loop
            l = l + 1
        Loop While l < MaxRows 'Maxl
        If Maxl <> 0 Then
            With Me.ListBox1
                .ListIndex = ListIdx
                エナブルドチュルー
            End With
        Else
            フォーム消去
            ChangeSwitch = False
            エナブルドフォルス
        End If
    End If
   
    If OptionButton2.Value = True Then
        l = 0
        Do '黄(火木土AM)の処理
            iro = OldMember(l).iro
            Do While iro = 6
                If OldMember(l).iro <> 6 Then
                    Exit Do
                End If
       
                TeijiYaku.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
                Maxl = Maxl + 1
            Loop
            l = l + 1
        Loop While l < MaxRows 'Maxl
       
        l = 0
        Do '緑(火木土PM)の処理
            iro = OldMember(l).iro
            Do While iro = 4
                If OldMember(l).iro <> 4 Then
                    Exit Do
                End If
       
                TeijiYaku.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
                Maxl = Maxl + 1
            Loop
            l = l + 1
        Loop While l < MaxRows 'Maxl
   
        If Maxl <> 0 Then
            With Me.ListBox1
                .ListIndex = ListIdx
                エナブルドチュルー
            End With
        Else
            フォーム消去
            ChangeSwitch = False
            エナブルドフォルス
        End If
    End If
End Sub
Private Sub ListBox1_Click()
    Dim Namae As String
   
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    ListIdx = ListBox1.ListIndex
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub

Private Sub CommandButton1_Click()
    Call 個別へ表示(ByVal l)
End Sub

Private Sub CommandButton2_Click()
    Dim Namae As String
    Dim MeNamae As Object
   
    OptionButton1.Value = False
    OptionButton2.Value = False
    Namae = TextBox1.Text
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    フォーム消去
    ChangeSwitch = False
    Set MeNamae = TeijiYaku
    Call 検索(Namae, MeNamae)
   
    エナブルドフォルス
End Sub

Sub 個別へ表示(ByVal l As Integer)
    Dim Maisu As Integer
    Dim MaisuHyoji As String
   
    Maisu = 0
    With OldMember(l)
   
        TeijiYaku.ComboBox1.Text = .YakuZai(0, 0)
        TeijiYaku.ComboBox2.Text = .YakuZai(0, 1)
        TeijiYaku.ComboBox3.Text = .YakuZai(0, 2)
        TeijiYaku.ComboBox4.Text = .YakuZai(0, 3)
        TeijiYaku.ComboBox5.Text = .YakuZai(0, 4)
        TeijiYaku.ComboBox6.Text = .YakuZai(0, 5)
        TeijiYaku.ComboBox7.Text = .YakuZai(0, 6)
        TeijiYaku.ComboBox8.Text = .YakuZai(0, 7)
        TeijiYaku.ComboBox9.Text = .YakuZai(0, 8)
        TeijiYaku.ComboBox10.Text = .YakuZai(0, 9)
        TeijiYaku.ComboBox11.Text = .YakuZai(0, 10)
       
        TeijiYaku.ComboBox12.Text = .YakuZai(1, 0)
        TeijiYaku.ComboBox13.Text = .YakuZai(1, 1)
        TeijiYaku.ComboBox14.Text = .YakuZai(1, 2)
        TeijiYaku.ComboBox15.Text = .YakuZai(1, 3)
        TeijiYaku.ComboBox16.Text = .YakuZai(1, 4)
        TeijiYaku.ComboBox17.Text = .YakuZai(1, 5)
        TeijiYaku.ComboBox18.Text = .YakuZai(1, 6)
        TeijiYaku.ComboBox19.Text = .YakuZai(1, 7)
        TeijiYaku.ComboBox20.Text = .YakuZai(1, 8)
        TeijiYaku.ComboBox21.Text = .YakuZai(1, 9)
        TeijiYaku.ComboBox22.Text = .YakuZai(1, 10)
       
        TeijiYaku.ComboBox39.Text = .YakuZai(2, 0)
        TeijiYaku.ComboBox40.Text = .YakuZai(2, 1)
        TeijiYaku.ComboBox41.Text = .YakuZai(2, 2)
        TeijiYaku.ComboBox42.Text = .YakuZai(2, 3)
        TeijiYaku.ComboBox43.Text = .YakuZai(2, 4)
        TeijiYaku.ComboBox44.Text = .YakuZai(2, 5)
        TeijiYaku.ComboBox45.Text = .YakuZai(2, 6)
        TeijiYaku.ComboBox46.Text = .YakuZai(2, 7)
        TeijiYaku.ComboBox47.Text = .YakuZai(2, 8)
        TeijiYaku.ComboBox48.Text = .YakuZai(2, 9)
        TeijiYaku.ComboBox49.Text = .YakuZai(2, 10)
        TeijiYaku.Label1.Caption = .Simei4
       
        TeijiYaku.Frame1.Caption = .Yobi(0)
        TeijiYaku.Frame2.Caption = .Yobi(1)
        TeijiYaku.Frame4.Caption = .Yobi(2)
       
        If .AutoInsatsu = True Then
            Me.ComboBox37.ListIndex = 1
        Else
            Me.ComboBox37.ListIndex = 0
        End If
        Me.ComboBox38.Text = .ShindanI
    End With
    Maisu = 処方箋の枚数(ByVal l)
    MaisuHyoji = "全" & Maisu & "枚"
    Me.Label7.Caption = MaisuHyoji
    エナブルドチュルー
    ChangeSwitch = False
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer

    For l = 0 To MaxRows 'Maxl
        If OldMember(l).Simei1 = Namae Then
            Kensaku = l
            Exit For
        End If
    Next
           
End Function

Private Sub CxBtn_Click()
    Dim Rtn As Integer
   
    Rtn = MsgBox("転送せずに終了します。よろしければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload TeijiYaku
        AboutForm.Show
    End If
End Sub

Private Sub ExitBtn_Click()
    Rtn = MsgBox("今まで行った変更を、ワークシートへ転送します。よろしければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        保存忘れ防止装置
        変更を保存して終了
        Unload TeijiYaku
        AboutForm.Show
    End If
End Sub
Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
    Dim K As Byte
   
    l = 0
   
    TeijiYaku.Hide
   
        For i = 3 To MaxRows
                      
            With OldMember(l)
           
                If .HenkoSwitch = True Then
                    '名前転送
                    Touseki.Cells(i, 3).Activate
                    Touseki.Cells(i, 3) = .Simei1
                   
                    '診断医の転送
                    Touseki.Cells(i, Ishi) = .ShindanI
                       
                    '自動印刷する・しない("院外処方"の文字)の転送
                    If .AutoInsatsu = True Then
                        Touseki.Cells(i, MarkIngai) = "院外処方"
                    Else
                        Touseki.Cells(i, MarkIngai) = ""
                    End If
                   
                    '注射薬の転送
               
                    For K = 0 To 2
                        Touseki.Cells(i, Syoho(0, 0) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 0) + K * 12) = .YakuZai(K, 0) '処方①
                   
                        Touseki.Cells(i, Syoho(0, 1) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 1) + K * 12) = .YakuZai(K, 1) '処方②
                   
                        Touseki.Cells(i, Syoho(0, 2) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 2) + K * 12) = .YakuZai(K, 2) '処方③
                   
                        Touseki.Cells(i, Syoho(0, 3) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 3) + K * 12) = .YakuZai(K, 3) '処方④
                   
                        Touseki.Cells(i, Syoho(0, 4) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 4) + K * 12) = .YakuZai(K, 4) '処方⑤
                   
                        Touseki.Cells(i, Syoho(0, 5) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 5) + K * 12) = .YakuZai(K, 5) '処方⑧
                   
                        Touseki.Cells(i, Syoho(0, 6) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 6) + K * 12) = .YakuZai(K, 6) '処方⑦
                  
                        Touseki.Cells(i, Syoho(0, 7) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 7) + K * 12) = .YakuZai(K, 7) '処方⑧
                   
                        Touseki.Cells(i, Syoho(0, 8) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 8) + K * 12) = .YakuZai(K, 8) '処方⑨
                   
                        Touseki.Cells(i, Syoho(0, 9) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 9) + K * 12) = .YakuZai(K, 9) '処方⑩
                   
                        Touseki.Cells(i, Syoho(0, 10) + K * 12).Activate
                        Touseki.Cells(i, Syoho(0, 10) + K * 12) = .YakuZai(K, 10) '処方⑪
                    Next
                   
                End If
                                   
            End With
            l = l + 1
        Next
   
    MsgBox ("データの転送が終了しました")
   
End Sub

Sub 保存忘れ防止装置()
    Dim Rtn As Byte
    If ChangeSwitch = True Then
        個別データ更新
    End If
    ChangeSwitch = False
End Sub

Private Sub 個別データ更新()
    ChangeSwitch = False
    Call 処方変数の更新(ByVal l)
End Sub

Sub 処方変数の更新(ByVal l As Integer)
   
    With OldMember(l)
        .HenkoSwitch = True
       
        .YakuZai(0, 0) = TeijiYaku.ComboBox1.Text
        .YakuZai(0, 1) = TeijiYaku.ComboBox2.Text
        .YakuZai(0, 2) = TeijiYaku.ComboBox3.Text
        .YakuZai(0, 3) = TeijiYaku.ComboBox4.Text
        .YakuZai(0, 4) = TeijiYaku.ComboBox5.Text
        .YakuZai(0, 5) = TeijiYaku.ComboBox6.Text
        .YakuZai(0, 6) = TeijiYaku.ComboBox7.Text
        .YakuZai(0, 7) = TeijiYaku.ComboBox8.Text
        .YakuZai(0, 8) = TeijiYaku.ComboBox9.Text
        .YakuZai(0, 9) = TeijiYaku.ComboBox10.Text
        .YakuZai(0, 10) = TeijiYaku.ComboBox11.Text
       
        .YakuZai(1, 0) = TeijiYaku.ComboBox12.Text
        .YakuZai(1, 1) = TeijiYaku.ComboBox13.Text
        .YakuZai(1, 2) = TeijiYaku.ComboBox14.Text
        .YakuZai(1, 3) = TeijiYaku.ComboBox15.Text
        .YakuZai(1, 4) = TeijiYaku.ComboBox16.Text
        .YakuZai(1, 5) = TeijiYaku.ComboBox17.Text
        .YakuZai(1, 6) = TeijiYaku.ComboBox18.Text
        .YakuZai(1, 7) = TeijiYaku.ComboBox19.Text
        .YakuZai(1, 8) = TeijiYaku.ComboBox20.Text
        .YakuZai(1, 9) = TeijiYaku.ComboBox21.Text
        .YakuZai(1, 10) = TeijiYaku.ComboBox22.Text
       
        .YakuZai(2, 0) = TeijiYaku.ComboBox39.Text
        .YakuZai(2, 1) = TeijiYaku.ComboBox40.Text
        .YakuZai(2, 2) = TeijiYaku.ComboBox41.Text
        .YakuZai(2, 3) = TeijiYaku.ComboBox42.Text
        .YakuZai(2, 4) = TeijiYaku.ComboBox43.Text
        .YakuZai(2, 5) = TeijiYaku.ComboBox44.Text
        .YakuZai(2, 6) = TeijiYaku.ComboBox45.Text
        .YakuZai(2, 7) = TeijiYaku.ComboBox46.Text
        .YakuZai(2, 8) = TeijiYaku.ComboBox47.Text
        .YakuZai(2, 9) = TeijiYaku.ComboBox48.Text
        .YakuZai(2, 10) = TeijiYaku.ComboBox49.Text
        .AutoInsatsu = TeijiYaku.ComboBox37.ListIndex
        .ShindanI = ComboBox38.Text
       
    End With
End Sub
       
   
Sub 定時薬テンプ作成()
    Dim Tate As Integer
    Dim Yoko As Integer
    Dim Tempu As String
    Dim Tempulist As Object
   
    Set Tempulist = Worksheets("テンプレート集")
   
    '診断医
    Tate = 3
    Yoko = 14
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox38.AddItem (Tempu)
    Tate = Tate + 1
    Loop While Tempu <> ""
   
    '定時薬薬剤
    Tate = 3
    Yoko = 15
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox1.AddItem (Tempu)
        ComboBox2.AddItem (Tempu)
        ComboBox3.AddItem (Tempu)
        ComboBox4.AddItem (Tempu)
        ComboBox5.AddItem (Tempu)
        ComboBox6.AddItem (Tempu)
        ComboBox7.AddItem (Tempu)
        ComboBox8.AddItem (Tempu)
        ComboBox9.AddItem (Tempu)
        ComboBox10.AddItem (Tempu)
        ComboBox11.AddItem (Tempu)
        ComboBox12.AddItem (Tempu)
        ComboBox13.AddItem (Tempu)
        ComboBox14.AddItem (Tempu)
        ComboBox15.AddItem (Tempu)
        ComboBox16.AddItem (Tempu)
        ComboBox17.AddItem (Tempu)
        ComboBox18.AddItem (Tempu)
        ComboBox19.AddItem (Tempu)
        ComboBox20.AddItem (Tempu)
        ComboBox21.AddItem (Tempu)
        ComboBox22.AddItem (Tempu)
        ComboBox39.AddItem (Tempu)
        ComboBox40.AddItem (Tempu)
        ComboBox41.AddItem (Tempu)
        ComboBox42.AddItem (Tempu)
        ComboBox43.AddItem (Tempu)
        ComboBox44.AddItem (Tempu)
        ComboBox45.AddItem (Tempu)
        ComboBox46.AddItem (Tempu)
        ComboBox47.AddItem (Tempu)
        ComboBox48.AddItem (Tempu)
        ComboBox49.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
End Sub


Private Sub ComboBox1_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox10_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox11_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox12_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox13_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox14_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox15_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox16_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox17_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox18_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox19_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox2_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox20_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox21_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox22_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox3_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox37_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox38_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox4_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox5_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox6_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox7_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox8_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox9_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox39_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox40_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox41_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox42_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox43_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox44_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox45_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox46_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox47_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox48_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox49_Change()
    ChangeSwitch = True
End Sub
Private Sub エナブルドチュルー()
    With Me
        .ComboBox1.Enabled = True
        .ComboBox2.Enabled = True
        .ComboBox3.Enabled = True
        .ComboBox4.Enabled = True
        .ComboBox5.Enabled = True
        .ComboBox6.Enabled = True
        .ComboBox7.Enabled = True
        .ComboBox8.Enabled = True
        .ComboBox9.Enabled = True
        .ComboBox10.Enabled = True
        .ComboBox11.Enabled = True
       
        .ComboBox12.Enabled = True
        .ComboBox13.Enabled = True
        .ComboBox14.Enabled = True
        .ComboBox15.Enabled = True
        .ComboBox16.Enabled = True
        .ComboBox17.Enabled = True
        .ComboBox18.Enabled = True
        .ComboBox19.Enabled = True
        .ComboBox20.Enabled = True
        .ComboBox21.Enabled = True
        .ComboBox22.Enabled = True
       
        .ComboBox39.Enabled = True
        .ComboBox40.Enabled = True
        .ComboBox41.Enabled = True
        .ComboBox42.Enabled = True
        .ComboBox43.Enabled = True
        .ComboBox44.Enabled = True
        .ComboBox45.Enabled = True
        .ComboBox46.Enabled = True
        .ComboBox47.Enabled = True
        .ComboBox48.Enabled = True
        .ComboBox49.Enabled = True
       
        .ComboBox37.Enabled = True
        .ComboBox38.Enabled = True
        .ExitBtn.Enabled = True
        .CommandButton1.Enabled = True
    End With
End Sub
Private Sub エナブルドフォルス()
    With Me
        .ComboBox1.Enabled = False
        .ComboBox2.Enabled = False
        .ComboBox3.Enabled = False
        .ComboBox4.Enabled = False
        .ComboBox5.Enabled = False
        .ComboBox6.Enabled = False
        .ComboBox7.Enabled = False
        .ComboBox8.Enabled = False
        .ComboBox9.Enabled = False
        .ComboBox10.Enabled = False
        .ComboBox11.Enabled = False
       
        .ComboBox12.Enabled = False
        .ComboBox13.Enabled = False
        .ComboBox14.Enabled = False
        .ComboBox15.Enabled = False
        .ComboBox16.Enabled = False
        .ComboBox17.Enabled = False
        .ComboBox18.Enabled = False
        .ComboBox19.Enabled = False
        .ComboBox20.Enabled = False
        .ComboBox21.Enabled = False
        .ComboBox22.Enabled = False
       
        .ComboBox39.Enabled = False
        .ComboBox40.Enabled = False
        .ComboBox41.Enabled = False
        .ComboBox42.Enabled = False
        .ComboBox43.Enabled = False
        .ComboBox44.Enabled = False
        .ComboBox45.Enabled = False
        .ComboBox46.Enabled = False
        .ComboBox47.Enabled = False
        .ComboBox48.Enabled = False
        .ComboBox49.Enabled = False
       
        ComboBox37.Enabled = False
        ComboBox38.Enabled = False
        ExitBtn.Enabled = False
        .CommandButton1.Enabled = False
    End With
End Sub
Private Sub フォーム消去()
    With Me
        .ComboBox1.Text = ""
        .ComboBox2.Text = ""
        .ComboBox3.Text = ""
        .ComboBox4.Text = ""
        .ComboBox5.Text = ""
        .ComboBox6.Text = ""
        .ComboBox7.Text = ""
        .ComboBox8.Text = ""
        .ComboBox9.Text = ""
        .ComboBox10.Text = ""
        .ComboBox11.Text = ""
       
        .ComboBox12.Text = ""
        .ComboBox13.Text = ""
        .ComboBox14.Text = ""
        .ComboBox15.Text = ""
        .ComboBox16.Text = ""
        .ComboBox17.Text = ""
        .ComboBox18.Text = ""
        .ComboBox19.Text = ""
        .ComboBox20.Text = ""
        .ComboBox21.Text = ""
        .ComboBox22.Text = ""
       
        .ComboBox39.Text = ""
        .ComboBox40.Text = ""
        .ComboBox41.Text = ""
        .ComboBox42.Text = ""
        .ComboBox43.Text = ""
        .ComboBox44.Text = ""
        .ComboBox45.Text = ""
        .ComboBox46.Text = ""
        .ComboBox47.Text = ""
        .ComboBox48.Text = ""
        .ComboBox49.Text = ""
        .Label1.Caption = ""
       
        .Frame1.Caption = ""
        .Frame2.Caption = ""
        .Frame4.Caption = ""
        .Label7.Caption = ""
        ComboBox37.Text = "しない"
        ComboBox38.Text = ""
    End With
End Sub

Private Function 処方箋の枚数(ByVal l As Integer)
    Dim Kotae As Boolean
    Dim Page As Integer
    Dim i As Integer
   
    Page = 0
    For i = 0 To 2
        Kotae = 空欄か空欄ではないか、それが問題だ(l, i)
        If Kotae = False Then
            Page = Page + 1
        End If
    Next
    処方箋の枚数 = Page
End Function
Private Function 空欄か空欄ではないか、それが問題だ(ByVal l As Integer, Hikisu As Integer) As Byte
    Dim i As Integer
   
    For i = 0 To 10
        If OldMember(l).YakuZai(Hikisu, i) <> "" Then
            空欄か空欄ではないか、それが問題だ = False
            Exit For
        Else
            If i = 10 Then
                空欄か空欄ではないか、それが問題だ = True
            End If
        End If
    Next
End Function


追記を閉じる▲

【2008/03/12 21:22】 | エクセルVBAで作った透析データベース
トラックバック(0) |

このフォームは患者さんに使う注射薬を確認編集するための物です。


コンボボックスに注射の一覧が表示されその中から選ぶことで変更します。

コンボボックスへ読み込む注射薬の一覧はエクセルのワークシートに記載しています。 注射薬に限らず、ほぼすべてのフォームのリストボックスやコンボボックスへ読み込むデータはまとめてワークシートに記載しています。各フォームはそこから選択肢であるリストを読み込んでいます。こうすることで一々Visual Basic Editorを開いてコードをいじらなくてもリストの内容を書き換えられるようにしてあります。


注射薬変更フォーム


リストの内容をまとめて書き表しているエクセルのワークシートです。(下記図参照) 

テンプレートのワークシート(1)

テンプレートのワークシート(2)


 このフォームのコードは以下記載です。 (続きを読むをクリックしてください)

Dim Touseki As Object
Dim iro As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer

Private Type MemberData
    Simei1 As String
    Simei4 As String
    Ocyusya(3, 11) As String
    Yobi(3) As String
    iro As Integer
    HenkoSwitch As Boolean
End Type

Dim OldMember() As MemberData
'Dim HenkoSwitch() As Boolean
Dim ChangeSwitch As Boolean
Dim l As Integer


Private Sub CommandButton2_Click()
    Dim Namae As String
    Dim MeNamae As Object
   
    OptionButton1.Value = False
    OptionButton2.Value = False
    'OptionButton3.Value = False
    Namae = TextBox1.Text
    Set MeNamae = Cyusya
    Call 検索(Namae, MeNamae)
End Sub

Private Sub CommandButton3_Click()
    Call 個別へ表示(ByVal l)
End Sub

Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
    'ChangeSwitch = False
   
    Call Member
    OptionButton1.Value = True
    注射薬テンプ作成
End Sub

Private Sub Member()
    ReDim OldMember(MaxRows)
    Dim K As Byte
   
    l = 0

    With Touseki
        For i = 3 To MaxRows
           
            With OldMember(l)
                .Simei1 = Touseki.Cells(i, 3)
                .Simei4 = Touseki.Cells(i, 2)
                For K = 0 To 2
                    .Ocyusya(K, 0) = Touseki.Cells(i, 70 + 9 * K)  'エルシト
                    .Ocyusya(K, 1) = Touseki.Cells(i, 71 + 9 * K)  'キド
                    .Ocyusya(K, 2) = Touseki.Cells(i, 72 + 9 * K)  'グリマ
                    .Ocyusya(K, 3) = Touseki.Cells(i, 73 + 9 * K)  'ミノ
                    .Ocyusya(K, 4) = Touseki.Cells(i, 74 + 9 * K)  'ノイロ
                    .Ocyusya(K, 5) = Touseki.Cells(i, 75 + 9 * K)  'アデラ
                    .Ocyusya(K, 6) = Touseki.Cells(i, 76 + 9 * K) 'エポ
                    .Ocyusya(K, 7) = Touseki.Cells(i, 77 + 9 * K) 'オキサ
                    .Ocyusya(K, 8) = Touseki.Cells(i, 78 + 9 * K) 'リクセル
                   
                    .Yobi(K) = Touseki.Cells(i, 33 + K)
                Next
                .HenkoSwitch = False
                .iro = Touseki.Cells(i, 1).Interior.ColorIndex
            End With
            'HenkoSwitch(l) = False
               
            l = l + 1
        Next
        Maxl = l
    End With
End Sub

Private Sub ListBox1_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    ListIdx = ListBox1.ListIndex
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub
Private Sub Optionbutton1_Change()
    If OptionButton1.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        ListIdx = 0
        氏名box
    End If
End Sub

Private Sub CxBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("転送せずに終了します。それでよければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload Cyusya
        AboutForm.Show
    End If
End Sub

Private Sub ExitBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("今まで行った変更を、ワークシートへ転送します。よろしければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        変更を保存して終了
       
        Unload Cyusya
        MsgBox ("転送を終了しました。")
        AboutForm.Show
    End If
   
End Sub
Private Sub Optionbutton2_Change()
    If OptionButton2.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        ListIdx = 0
        氏名box
    End If
End Sub

Private Sub InputBtn_Click()
    'ChangeSwitch = False
    'Call 注射変数の更新(ByVal l)
End Sub
Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    Cyusya.ListBox1.Clear
    ListIdx = 0
   
    If OptionButton1.Value = True Then

        l = 0
        Do '赤(月水金AM)の処理
            iro = OldMember(l).iro
            Do While iro = 3
                If OldMember(l).iro <> 3 Then
                    Exit Do
                End If
       
                Cyusya.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '青(月水金PM)の処理
            iro = OldMember(l).iro
            Do While iro = 5
                If OldMember(l).iro <> 5 Then
                    Exit Do
                End If
       
                Cyusya.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        With Cyusya.ListBox1
            .ListIndex = ListIdx
        End With
    End If
   
    If OptionButton2.Value = True Then
        l = 0
        Do '黄(火木土AM)の処理
            iro = OldMember(l).iro
            Do While iro = 6
                If OldMember(l).iro <> 6 Then
                    Exit Do
                End If
       
                Cyusya.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '緑(火木土PM)の処理
            iro = OldMember(l).iro
            Do While iro = 4
                If OldMember(l).iro <> 4 Then
                    Exit Do
                End If
       
                Cyusya.ListBox1.AddItem (OldMember(l).Simei1)
               
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
   
        With Cyusya.ListBox1
            .ListIndex = ListIdx
        End With
       
    End If
End Sub

Sub 個別へ表示(ByVal l As Integer)
   
        Cyusya.ComboBox1.Text = OldMember(l).Ocyusya(0, 0)
        Cyusya.ComboBox4.Text = OldMember(l).Ocyusya(0, 1)
        Cyusya.ComboBox7.Text = OldMember(l).Ocyusya(0, 2)
        Cyusya.ComboBox10.Text = OldMember(l).Ocyusya(0, 3)
        Cyusya.ComboBox13.Text = OldMember(l).Ocyusya(0, 4)
        Cyusya.ComboBox16.Text = OldMember(l).Ocyusya(0, 5)
        Cyusya.ComboBox19.Text = OldMember(l).Ocyusya(0, 6)
        Cyusya.ComboBox22.Text = OldMember(l).Ocyusya(0, 7)
        Cyusya.ComboBox25.Text = OldMember(l).Ocyusya(0, 8)
       
        Cyusya.ComboBox2.Text = OldMember(l).Ocyusya(1, 0)
        Cyusya.ComboBox5.Text = OldMember(l).Ocyusya(1, 1)
        Cyusya.ComboBox8.Text = OldMember(l).Ocyusya(1, 2)
        Cyusya.ComboBox11.Text = OldMember(l).Ocyusya(1, 3)
        Cyusya.ComboBox14.Text = OldMember(l).Ocyusya(1, 4)
        Cyusya.ComboBox17.Text = OldMember(l).Ocyusya(1, 5)
        Cyusya.ComboBox20.Text = OldMember(l).Ocyusya(1, 6)
        Cyusya.ComboBox23.Text = OldMember(l).Ocyusya(1, 7)
        Cyusya.ComboBox26.Text = OldMember(l).Ocyusya(1, 8)
       
        Cyusya.ComboBox3.Text = OldMember(l).Ocyusya(2, 0)
        Cyusya.ComboBox6.Text = OldMember(l).Ocyusya(2, 1)
        Cyusya.ComboBox9.Text = OldMember(l).Ocyusya(2, 2)
        Cyusya.ComboBox12.Text = OldMember(l).Ocyusya(2, 3)
        Cyusya.ComboBox15.Text = OldMember(l).Ocyusya(2, 4)
        Cyusya.ComboBox18.Text = OldMember(l).Ocyusya(2, 5)
        Cyusya.ComboBox21.Text = OldMember(l).Ocyusya(2, 6)
        Cyusya.ComboBox24.Text = OldMember(l).Ocyusya(2, 7)
        Cyusya.ComboBox27.Text = OldMember(l).Ocyusya(2, 8)
       
    Cyusya.Label43.Caption = OldMember(l).Simei4
   
    Cyusya.Frame1.Caption = OldMember(l).Yobi(0)
    Cyusya.Frame2.Caption = OldMember(l).Yobi(1)
    Cyusya.Frame3.Caption = OldMember(l).Yobi(2)
    'Call 曜日更新(ByVal l)
    ChangeSwitch = False
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer

    For l = 0 To Maxl
        If OldMember(l).Simei1 = Namae Then
            Kensaku = l
            Exit For
        End If
    Next
           
End Function


Sub 保存忘れ防止装置()
    'Dim Rtn As Byte
   
    'Rtn = MsgBox(OldMember(l).Simei4 & "さんの変更を保存しますか?", vbYesNo, "保存確認")
    'If Rtn = vbYes Then
    '    InputBtn_Click
    'End If
    If ChangeSwitch = True Then
        ChangeSwitch = False
        Call 注射変数の更新(ByVal l)
        '氏名box
    End If
    'ChangeSwitch = False
End Sub
Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
    Dim K As Byte
    Dim j As Byte
   
    l = 0
   
    Cyusya.Hide
   
        For i = 3 To MaxRows
            If OldMember(l).HenkoSwitch = True Then
           
                With OldMember(l)
                '名前転送
                    Touseki.Cells(i, 3).Activate
                    Touseki.Cells(i, 3) = .Simei1
                   
                '注射薬の転送
               
                    For K = 0 To 2
                        For j = 0 To 8
                            Touseki.Cells(i, 70 + j + K * 9).Activate
                            Touseki.Cells(i, 70 + j + K * 9) = .Ocyusya(K, j) 'エルシト
                        Next
                    Next
                End With
                                 
            End If
            l = l + 1
        Next

End Sub



Sub 注射変数の更新(ByVal l As Integer)
    'HenkoSwitch(l) = True
   
    With OldMember(l)
        .HenkoSwitch = True
           
        .Ocyusya(0, 0) = Cyusya.ComboBox1.Text
        .Ocyusya(0, 1) = Cyusya.ComboBox4.Text
        .Ocyusya(0, 2) = Cyusya.ComboBox7.Text
        .Ocyusya(0, 3) = Cyusya.ComboBox10.Text
        .Ocyusya(0, 4) = Cyusya.ComboBox13.Text
        .Ocyusya(0, 5) = Cyusya.ComboBox16.Text
        .Ocyusya(0, 6) = Cyusya.ComboBox19.Text
        .Ocyusya(0, 7) = Cyusya.ComboBox22.Text
        .Ocyusya(0, 8) = Cyusya.ComboBox25.Text
       
        .Ocyusya(1, 0) = Cyusya.ComboBox2.Text
        .Ocyusya(1, 1) = Cyusya.ComboBox5.Text
        .Ocyusya(1, 2) = Cyusya.ComboBox8.Text
        .Ocyusya(1, 3) = Cyusya.ComboBox11.Text
        .Ocyusya(1, 4) = Cyusya.ComboBox14.Text
        .Ocyusya(1, 5) = Cyusya.ComboBox17.Text
        .Ocyusya(1, 6) = Cyusya.ComboBox20.Text
        .Ocyusya(1, 7) = Cyusya.ComboBox23.Text
        .Ocyusya(1, 8) = Cyusya.ComboBox26.Text
       
        .Ocyusya(2, 0) = Cyusya.ComboBox3.Text
        .Ocyusya(2, 1) = Cyusya.ComboBox6.Text
        .Ocyusya(2, 2) = Cyusya.ComboBox9.Text
        .Ocyusya(2, 3) = Cyusya.ComboBox12.Text
        .Ocyusya(2, 4) = Cyusya.ComboBox15.Text
        .Ocyusya(2, 5) = Cyusya.ComboBox18.Text
        .Ocyusya(2, 6) = Cyusya.ComboBox21.Text
        .Ocyusya(2, 7) = Cyusya.ComboBox24.Text
        .Ocyusya(2, 8) = Cyusya.ComboBox27.Text
    End With
End Sub
       


Sub 注射薬テンプ作成()
    Dim Tate As Integer
    Dim Yoko As Integer
    Dim Tempu As String
    Set Tempulist = Worksheets("テンプレート集")
   
    'エルシトニンのテンプレート
    Tate = 3
    Yoko = 26
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox1.AddItem (Tempu)
        ComboBox2.AddItem (Tempu)
        ComboBox3.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
    'キドミンのテンプレート
    Tate = 3
    Yoko = 27
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox4.AddItem (Tempu)
        ComboBox5.AddItem (Tempu)
        ComboBox6.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'グリマッケンのテンプレート
    Tate = 3
    Yoko = 28
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox7.AddItem (Tempu)
        ComboBox8.AddItem (Tempu)
        ComboBox9.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'キョウミノのテンプレート
    Tate = 3
    Yoko = 29
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox10.AddItem (Tempu)
        ComboBox11.AddItem (Tempu)
        ComboBox12.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ノイロのテンプレート
    Tate = 3
    Yoko = 30
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox13.AddItem (Tempu)
        ComboBox14.AddItem (Tempu)
        ComboBox15.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'アデラのテンプレート
    Tate = 3
    Yoko = 31
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox16.AddItem (Tempu)
        ComboBox17.AddItem (Tempu)
        ComboBox18.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'エポのテンプレート
    Tate = 3
    Yoko = 32
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox19.AddItem (Tempu)
        ComboBox20.AddItem (Tempu)
        ComboBox21.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'オキサのテンプレート
    Tate = 3
    Yoko = 33
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox22.AddItem (Tempu)
        ComboBox23.AddItem (Tempu)
        ComboBox24.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'リクセルのテンプレート
    Tate = 3
    Yoko = 34
    Tempu = ""
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox25.AddItem (Tempu)
        ComboBox26.AddItem (Tempu)
        ComboBox27.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
End Sub


Private Sub ComboBox1_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox10_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox11_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox12_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox13_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox14_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox15_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox16_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox17_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox18_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox19_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox2_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox20_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox21_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox22_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox23_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox24_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox25_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox26_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox27_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox28_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox29_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox3_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox30_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox31_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox32_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox33_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox4_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox5_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox6_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox7_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox8_Change()
    ChangeSwitch = True
End Sub

Private Sub ComboBox9_Change()
    ChangeSwitch = True
End Sub


追記を閉じる▲

【2008/03/12 21:19】 | エクセルVBAで作った透析データベース
トラックバック(0) |

これは透析の日付を編集するためのフォームです。透析の場合患者さんによって月・水・金と火・木・土に分かれます。そして同じ曜日でも午前中と午後に分かれます。


経過表を作る場合、日付を1週ごとに新しくする必要があります。個別に患者さんの都合で変更することもあります。そのためにまとめて1週間進めるためのボタンと、個別に変更できるボタンを設置しております。

日付変更フォーム



日付変更フォームマクロ写真

Dim Touseki As Object
Dim iro As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer
Dim Hosu7 As Single

Private Type MemberData
    Simei1 As String
    Simei4 As String
    Hizuke1 As Date
    Hizuke2 As Date
    Hizuke3 As Date
    iro As Integer
    HenkoSwitch As Boolean
End Type

Dim OldMember() As MemberData
Dim l As Integer
Dim YMD(3, 3) As String
Dim ChangeSwitch As Boolean

Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
   
    Call Member
    Call 日付テンプ作成
    OptionButton1.Value = True
End Sub

Private Sub Member()
    Dim CelNo(3) As String
    Dim i As Integer
   
    ReDim OldMember(MaxRows)
   
    l = 0
    With Touseki
        For i = 3 To MaxRows
           
            With OldMember(l)
                .Simei1 = Touseki.Cells(i, 3)
                .Simei4 = Touseki.Cells(i, 2)
                .Hizuke1 = CDate(Touseki.Cells(i, 30))
                .Hizuke2 = CDate(Touseki.Cells(i, 31))
                .Hizuke3 = CDate(Touseki.Cells(i, 32))
                .iro = Touseki.Cells(i, 1).Interior.ColorIndex
                .HenkoSwitch = False
            End With
           
            l = l + 1
        Next
        Maxl = l
    End With
End Sub
Public Function Ninzu() As Integer

    Dim Torikomi As String
    Dim Torikomi2 As String
   
    Ninzu = 1
    For i = 2 To MaxRows
       
        If Torikomi <> Torikomi2 Then
           
            If Torikomi2 <> "" Then
                Ninzu = Ninzu + 1
                Torikomi = Touseki.Cells(i + 1, 3)
                Torikomi2 = Touseki.Cells(i + 2, 3)
            Else
                Torikomi = Touseki.Cells(i, 3)
                Torikomi2 = Touseki.Cells(i + 2, 3)
            End If
        Else
            Torikomi = Touseki.Cells(i + 1, 3)
            Torikomi2 = Touseki.Cells(i + 2, 3)
        End If
       
    Next
   
End Function

Private Sub Optionbutton1_Change()
    If OptionButton1.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        氏名box
    End If
End Sub

Private Sub Optionbutton2_Change()
    If OptionButton2.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        氏名box
    End If
End Sub


Private Sub CommandButton1_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Hosu7 = 7
    Call まとめて変更
End Sub

Private Sub CommandButton3_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Hosu7 = -7
    Call まとめて変更
End Sub


Private Sub CxBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("保存せずに終了します。それでよければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload Hizuke
        AboutForm.Show
    End If
End Sub

Private Sub ExitBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("今まで行った変更を、保存します。よろしければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        変更を保存して終了
        Unload Hizuke
        MsgBox ("転送を終了しました。")
        AboutForm.Show
    End If
   
End Sub

Private Sub InputBtn_Click()

    個別変更内容チェック
    変数更新
    With OldMember(l)
        .Hizuke1 = DateSerial(CInt(YMD(0, 0)), CInt(YMD(0, 1)), CInt(YMD(0, 2)))
        .Hizuke2 = DateSerial(CInt(YMD(1, 0)), CInt(YMD(1, 1)), CInt(YMD(1, 2)))
        .Hizuke3 = DateSerial(CInt(YMD(2, 0)), CInt(YMD(2, 1)), CInt(YMD(2, 2)))
        .HenkoSwitch = True
    End With
    Call 氏名box
End Sub



Private Sub ListBox1_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    ListIdx = ListBox1.ListIndex
    ListBox2.ListIndex = ListIdx
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub

Private Sub ListBox2_Click()
    ListIdx = ListBox2.ListIndex
    ListBox1.ListIndex = ListIdx
End Sub

Sub 保存忘れ防止装置()
    If ChangeSwitch = True Then
        ChangeSwitch = False
        InputBtn_Click
    End If
End Sub
Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
   
    l = 0
   
    Hizuke.Hide
   
        For i = 3 To MaxRows
       
            With OldMember(l)
                If .HenkoSwitch = True Then
               
                '氏名更新
                    Touseki.Cells(i, 3).Activate
                    Touseki.Cells(i, 3) = .Simei1
                   
                '日付更新
                    Touseki.Cells(i, 30).Activate
                    If .Hizuke1 <> "0:00:00" Then
                        Touseki.Cells(i, 30) = .Hizuke1
                    Else
                        Touseki.Cells(i, 30) = ""
                    End If
                    Touseki.Cells(i, 31).Activate
                    If .Hizuke2 <> "0:00:00" Then
                        Touseki.Cells(i, 31) = .Hizuke2
                    Else
                        Touseki.Cells(i, 31) = ""
                    End If
                    Touseki.Cells(i, 32).Activate
                    If .Hizuke3 <> "0:00:00" Then
                        Touseki.Cells(i, 32) = .Hizuke3
                    Else
                        Touseki.Cells(i, 32) = ""
                    End If
                   
                    '曜日更新
                    Touseki.Cells(i, 33).Activate
                    If .Hizuke1 <> "0:00:00" Then
                        Touseki.Cells(i, 33) = WeekdayName(Weekday(.Hizuke1))
                    Else
                        Touseki.Cells(i, 33) = ""
                    End If
                    Touseki.Cells(i, 34).Activate
                    If .Hizuke2 <> "0:00:00" Then
                        Touseki.Cells(i, 34) = WeekdayName(Weekday(.Hizuke2))
                    Else
                        Touseki.Cells(i, 34) = ""
                    End If
                    Touseki.Cells(i, 35).Activate
                    If .Hizuke3 <> "0:00:00" Then
                        Touseki.Cells(i, 35) = WeekdayName(Weekday(.Hizuke3))
                    Else
                        Touseki.Cells(i, 35) = ""
                    End If
                End If
            End With
            l = l + 1
        Next
   
End Sub


Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    Hizuke.ListBox1.Clear
    Hizuke.ListBox2.Clear
    ListIdx = 0
   
    If OptionButton1.Value = True Then

        l = 0
        Do '赤(月水金AM)の処理
            iro = OldMember(l).iro
            Do While iro = 3
                If OldMember(l).iro <> 3 Then
                    Exit Do
                End If
       
                Hizuke.ListBox1.AddItem (OldMember(l).Simei1)
                Hizuke.ListBox2.AddItem (OldMember(l).Hizuke1 & "    " & OldMember(l).Hizuke2 & "    " & OldMember(l).Hizuke3 & "        ")
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '青(月水金PM)の処理
            iro = OldMember(l).iro
            Do While iro = 5
                If OldMember(l).iro <> 5 Then
                    Exit Do
                End If
       
                Hizuke.ListBox1.AddItem (OldMember(l).Simei1)
                Hizuke.ListBox2.AddItem (OldMember(l).Hizuke1 & "    " & OldMember(l).Hizuke2 & "    " & OldMember(l).Hizuke3 & "        ")
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        With Hizuke.ListBox1
            .ListIndex = ListIdx
        End With
    End If
   
    If OptionButton2.Value = True Then
        l = 0
        Do '黄(火木土AM)の処理
            iro = OldMember(l).iro
            Do While iro = 6
                If OldMember(l).iro <> 6 Then
                    Exit Do
                End If
       
                Hizuke.ListBox1.AddItem (OldMember(l).Simei1)
                Hizuke.ListBox2.AddItem (OldMember(l).Hizuke1 & "    " & OldMember(l).Hizuke2 & "    " & OldMember(l).Hizuke3 & "        ")
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '緑(火木土PM)の処理
            iro = OldMember(l).iro
            Do While iro = 4
                If OldMember(l).iro <> 4 Then
                    Exit Do
                End If
       
                Hizuke.ListBox1.AddItem (OldMember(l).Simei1)
                Hizuke.ListBox2.AddItem (OldMember(l).Hizuke1 & "    " & OldMember(l).Hizuke2 & "    " & OldMember(l).Hizuke3 & "        ")
                l = l + 1
           
            Loop
            l = l + 1
        Loop While l < Maxl
   
        With Hizuke.ListBox1
            .ListIndex = ListIdx
        End With
       
    End If
End Sub
Private Sub まとめて変更()
   
    Set Touseki = Worksheets("透析患者リスト")
   
'月・水・金の処理
    If OptionButton1.Value = True Then
       
        l = 0
        Do
           
            Do While OldMember(l).iro = 3
                OldMember(l).HenkoSwitch = True
               
                If OldMember(l).Hizuke1 <> "0:00:00" Then
                    OldMember(l).Hizuke1 = OldMember(l).Hizuke1 + Hosu7
                End If
                If OldMember(l).Hizuke2 <> "0:00:00" Then
                    OldMember(l).Hizuke2 = OldMember(l).Hizuke2 + Hosu7
                End If
                If OldMember(l).Hizuke3 <> "0:00:00" Then
                    OldMember(l).Hizuke3 = OldMember(l).Hizuke3 + Hosu7
                End If
                                                                   
                l = l + 1
               
            Loop
            l = l + 1
        Loop While l < Maxl
   
        l = 0
        Do
           
            Do While OldMember(l).iro = 5
                OldMember(l).HenkoSwitch = True
               
                If OldMember(l).Hizuke1 <> "0:00:00" Then
                    OldMember(l).Hizuke1 = OldMember(l).Hizuke1 + Hosu7
                End If
                If OldMember(l).Hizuke2 <> "0:00:00" Then
                    OldMember(l).Hizuke2 = OldMember(l).Hizuke2 + Hosu7
                End If
                If OldMember(l).Hizuke3 <> "0:00:00" Then
                    OldMember(l).Hizuke3 = OldMember(l).Hizuke3 + Hosu7
                End If
                                                                   
                l = l + 1
               
            Loop
            l = l + 1
        Loop While l < Maxl
    End If
   
       
'火・木・土の処理
    If OptionButton2.Value = True Then
        l = 0
        Do
           
            Do While OldMember(l).iro = 6
                OldMember(l).HenkoSwitch = True
               
                If OldMember(l).Hizuke1 <> "0:00:00" Then
                    OldMember(l).Hizuke1 = OldMember(l).Hizuke1 + Hosu7
                End If
                If OldMember(l).Hizuke2 <> "0:00:00" Then
                    OldMember(l).Hizuke2 = OldMember(l).Hizuke2 + Hosu7
                End If
                If OldMember(l).Hizuke3 <> "0:00:00" Then
                    OldMember(l).Hizuke3 = OldMember(l).Hizuke3 + Hosu7
                End If
                                                                   
                l = l + 1
               
            Loop
            l = l + 1
        Loop While l < Maxl
   
    l = 0
        Do
           
            Do While OldMember(l).iro = 4
                OldMember(l).HenkoSwitch = True
           
                If OldMember(l).Hizuke1 <> "0:00:00" Then
                    OldMember(l).Hizuke1 = OldMember(l).Hizuke1 + Hosu7
                End If
                If OldMember(l).Hizuke2 <> "0:00:00" Then
                    OldMember(l).Hizuke2 = OldMember(l).Hizuke2 + Hosu7
                End If
                If OldMember(l).Hizuke3 <> "0:00:00" Then
                    OldMember(l).Hizuke3 = OldMember(l).Hizuke3 + Hosu7
                End If
                                                                   
                l = l + 1
               
            Loop
            l = l + 1
        Loop While l < Maxl
    End If
    Call 氏名box
End Sub



Sub 個別へ表示(ByVal l As Integer)
   
    If OldMember(l).Hizuke1 <> "0:00:00" Then
        YMD(0, 0) = Year(OldMember(l).Hizuke1)
        YMD(0, 1) = Month(OldMember(l).Hizuke1)
        YMD(0, 2) = Day(OldMember(l).Hizuke1)
    Else
        YMD(0, 0) = "*"
        YMD(0, 1) = "*"
        YMD(0, 2) = "*"
    End If
    If OldMember(l).Hizuke2 <> "0:00:00" Then
        YMD(1, 0) = Year(OldMember(l).Hizuke2)
        YMD(1, 1) = Month(OldMember(l).Hizuke2)
        YMD(1, 2) = Day(OldMember(l).Hizuke2)
    Else
        YMD(1, 0) = "*"
        YMD(1, 1) = "*"
        YMD(1, 2) = "*"
    End If
    If OldMember(l).Hizuke3 <> "0:00:00" Then
        YMD(2, 0) = Year(OldMember(l).Hizuke3)
        YMD(2, 1) = Month(OldMember(l).Hizuke3)
        YMD(2, 2) = Day(OldMember(l).Hizuke3)
    Else
        YMD(2, 0) = "*"
        YMD(2, 1) = "*"
        YMD(2, 2) = "*"
    End If
   
    ComboBox1.Text = YMD(0, 0)
    ComboBox2.Text = YMD(0, 1)
    ComboBox3.Text = YMD(0, 2)
    ComboBox4.Text = YMD(1, 0)
    ComboBox5.Text = YMD(1, 1)
    ComboBox6.Text = YMD(1, 2)
    ComboBox7.Text = YMD(2, 0)
    ComboBox8.Text = YMD(2, 1)
    ComboBox9.Text = YMD(2, 2)
    Hizuke.Label30.Caption = OldMember(l).Simei4
    Call 曜日更新(ByVal l)
    ChangeSwitch = False
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer

    For l = 0 To Maxl
        If OldMember(l).Simei1 = Namae Then
            Kensaku = l
            Exit For
        End If
    Next
           
End Function

Sub 変数更新()
If ComboBox1.Text <> "*" Then
    YMD(0, 0) = ComboBox1.Text
Else
    YMD(0, 0) = "1899"
End If
If ComboBox2.Text <> "*" Then
    YMD(0, 1) = ComboBox2.Text
Else
    YMD(0, 1) = "12"
End If
If ComboBox3.Text <> "*" Then
    YMD(0, 2) = ComboBox3.Text
Else
    YMD(0, 2) = "30"
End If

If ComboBox4.Text <> "*" Then
    YMD(1, 0) = ComboBox4.Text
Else
    YMD(1, 0) = "1899"
End If
If ComboBox5.Text <> "*" Then
    YMD(1, 1) = ComboBox5.Text
Else
    YMD(1, 1) = "12"
End If
If ComboBox6.Text <> "*" Then
    YMD(1, 2) = ComboBox6.Text
Else
    YMD(1, 2) = "30"
End If

If ComboBox7.Text <> "*" Then
    YMD(2, 0) = ComboBox7.Text
Else
    YMD(2, 0) = "1899"
End If
If ComboBox8.Text <> "*" Then
    YMD(2, 1) = ComboBox8.Text
Else
    YMD(2, 1) = "12"
End If
If ComboBox9.Text <> "*" Then
    YMD(2, 2) = ComboBox9.Text
Else
    YMD(2, 2) = "30"
End If
   
End Sub
Sub 曜日更新(ByVal l As Integer)
    If OldMember(l).Hizuke1 <> "0:00:00" Then
        Label1.Caption = WeekdayName(Weekday(OldMember(l).Hizuke1))
    Else
        Label1.Caption = ""
    End If
    If OldMember(l).Hizuke2 <> "0:00:00" Then
        Label2.Caption = WeekdayName(Weekday(OldMember(l).Hizuke2))
    Else
        Label2.Caption = ""
    End If
    If OldMember(l).Hizuke3 <> "0:00:00" Then
        Label3.Caption = WeekdayName(Weekday(OldMember(l).Hizuke3))
    Else
        Label3.Caption = ""
    End If
End Sub
Sub 日付テンプ作成()
  
        ComboBox3.AddItem ("*")
        ComboBox6.AddItem ("*")
        ComboBox9.AddItem ("*")
   
        ComboBox2.AddItem ("*")
        ComboBox5.AddItem ("*")
        ComboBox8.AddItem ("*")
   
        ComboBox1.AddItem ("*")
        ComboBox4.AddItem ("*")
        ComboBox7.AddItem ("*")
   
    For i = 1 To 31
        ComboBox3.AddItem (i)
        ComboBox6.AddItem (i)
        ComboBox9.AddItem (i)
    Next
    For i = 1 To 12
        ComboBox2.AddItem (i)
        ComboBox5.AddItem (i)
        ComboBox8.AddItem (i)
    Next
    For i = 2003 To 2013
        ComboBox1.AddItem (i)
        ComboBox4.AddItem (i)
        ComboBox7.AddItem (i)
    Next
End Sub

Private Sub ComboBox1_Change()
    ChangeSwitch = True
    If ComboBox1.Text = "*" Then
        ComboBox2.Text = "*"
        ComboBox2.Text = "*"
    End If
End Sub

Private Sub ComboBox2_Change()
    ChangeSwitch = True
    If ComboBox2.Text = "*" Then
        ComboBox1.Text = "*"
        ComboBox3.Text = "*"
    End If
End Sub

Private Sub ComboBox3_Change()
    ChangeSwitch = True
    If ComboBox3.Text = "*" Then
        ComboBox1.Text = "*"
        ComboBox2.Text = "*"
    End If
End Sub

Private Sub ComboBox4_Change()
    ChangeSwitch = True
    If ComboBox4.Text = "*" Then
        ComboBox5.Text = "*"
        ComboBox6.Text = "*"
    End If
End Sub

Private Sub ComboBox5_Change()
    ChangeSwitch = True
    If ComboBox5.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox6.Text = "*"
    End If
End Sub

Private Sub ComboBox6_Change()
    ChangeSwitch = True
    If ComboBox6.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox5.Text = "*"
    End If
End Sub

Private Sub ComboBox7_Change()
    ChangeSwitch = True
    If ComboBox7.Text = "*" Then
        ComboBox8.Text = "*"
        ComboBox9.Text = "*"
    End If
End Sub

Private Sub ComboBox8_Change()
    ChangeSwitch = True
    If ComboBox8.Text = "*" Then
        ComboBox7.Text = "*"
        ComboBox9.Text = "*"
    End If
End Sub

Private Sub ComboBox9_Change()
    ChangeSwitch = True
    If ComboBox9.Text = "*" Then
        ComboBox7.Text = "*"
        ComboBox8.Text = "*"
    End If
End Sub

Private Sub 個別変更内容チェック()
    If ComboBox1.Text = "*" Then
        ComboBox2.Text = "*"
        ComboBox2.Text = "*"
    End If

    If ComboBox2.Text = "*" Then
        ComboBox1.Text = "*"
        ComboBox3.Text = "*"
    End If

    If ComboBox3.Text = "*" Then
        ComboBox1.Text = "*"
        ComboBox2.Text = "*"
    End If

    If ComboBox4.Text = "*" Then
        ComboBox5.Text = "*"
        ComboBox6.Text = "*"
    End If

    If ComboBox5.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox6.Text = "*"
    End If

    If ComboBox6.Text = "*" Then
        ComboBox4.Text = "*"
        ComboBox5.Text = "*"
    End If

    If ComboBox7.Text = "*" Then
        ComboBox8.Text = "*"
        ComboBox9.Text = "*"
    End If

    If ComboBox8.Text = "*" Then
        ComboBox7.Text = "*"
        ComboBox9.Text = "*"
    End If

    If ComboBox9.Text = "*" Then
        ComboBox7.Text = "*"
        ComboBox8.Text = "*"
    End If
End Sub


追記を閉じる▲

【2008/03/12 21:14】 | エクセルVBAで作った透析データベース
トラックバック(0) |
透析条件を編集するためのフォームです。透析条件とは透析時間から始まって使う機材の名前や針を刺す場所などの重要なデーターです。

選択して入力できるようにするためにコンボボックスやリストボックスを多用しております。コンボボックスやリストボックスのリスト一覧をエクセルのワークシート テンプレート集 から読み込みます。

患者さんの氏名を検索してその人の透析条件を表示させます。条件を編集したら元のエクセルのワークシートへ転送します。


氏名の検索は以前このブログで取り上げさせていただきました検索窓をすべてのフォーム共通で使っております。

エクセルのワークシートを使ったデータベースです。ワークシートからデーターを読み込みまた変更したものをワークシートへ転送します。

下のフォームは透析条件編集フォームです。

透析条件フォーム

Dim Touseki As Object
Dim Tcolor As Integer
Dim MaxRows As Long
Dim Maxl As Long
Dim ListIdx As Integer
Dim IdxNo As Integer

Private Type MemberData
    Simei1 As String
    Simei4 As String
    TosekiJikan As String
    Ryuryo As String
    BAA As String
    BAV As String
    BAS As String
    Dia As String
    Hepa As String
    LowHepa As String
    PenRes(3) As String
    iro As Integer
    HenkoSwitch As Boolean
End Type

Dim OldMember() As MemberData
Dim YMD(2, 3) As String
Dim ChangeSwitch As Boolean
Dim l As Integer
Dim Ranser As Boolean
Private Sub UserForm_Initialize()
    Set Touseki = Worksheets("透析患者リスト")
    Touseki.Activate
    MaxRows = Touseki.UsedRange.Rows.Count
    ListIdx = 0
    ChangeSwitch = False
   
    Call Member
    透析条件テンプ作成
    OptionButton1.Value = True
End Sub
Private Sub Member()
    ReDim OldMember(MaxRows)
   
    l = 0

        For i = 3 To MaxRows
            With OldMember(l)
                .Simei4 = Touseki.Cells(i, 2)
                .Simei1 = Touseki.Cells(i, 3)
                .TosekiJikan = Touseki.Cells(i, 16)
                .Ryuryo = Touseki.Cells(i, 11)
                .BAA = Touseki.Cells(i, 12)
                .BAV = Touseki.Cells(i, 13)
                .BAS = Touseki.Cells(i, 14)
                .Dia = Touseki.Cells(i, 15)
                .Hepa = Touseki.Cells(i, 9)
                .LowHepa = Touseki.Cells(i, 10)
                .PenRes(0) = Touseki.Cells(i, 100)
                .PenRes(1) = Touseki.Cells(i, 101)
                .PenRes(2) = Touseki.Cells(i, 102)
                .iro = Touseki.Cells(i, 1).Interior.ColorIndex
                .HenkoSwitch = False
            End With
            l = l + 1
        Next
        Maxl = l
End Sub
Private Sub 氏名box()
    Dim CelNo(3) As String
   
    Set Touseki = Worksheets("透析患者リスト")
    ListBox1.Clear
    ListIdx = 0
   
    If OptionButton1.Value = True Then

        l = 0
        Do '赤(月水金AM)の処理
            Do While OldMember(l).iro = 3
                Jyouken.ListBox1.AddItem (OldMember(l).Simei1)
                l = l + 1
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '青(月水金PM)の処理
            Do While OldMember(l).iro = 5
                Jyouken.ListBox1.AddItem (OldMember(l).Simei1)
                l = l + 1
            Loop
            l = l + 1
        Loop While l < Maxl
       
        With Jyouken.ListBox1
            .ListIndex = ListIdx
        End With
    End If
   
    If OptionButton2.Value = True Then
        l = 0
        Do '黄(火木土AM)の処理
            Do While OldMember(l).iro = 6
                Jyouken.ListBox1.AddItem (OldMember(l).Simei1)
                l = l + 1
            Loop
            l = l + 1
        Loop While l < Maxl
       
        l = 0
        Do '緑(火木土PM)の処理
            Do While OldMember(l).iro = 4
                Jyouken.ListBox1.AddItem (OldMember(l).Simei1)
                l = l + 1
            Loop
            l = l + 1
        Loop While l < Maxl
   
        With Jyouken.ListBox1
            .ListIndex = ListIdx
        End With
       
    End If
End Sub
Private Sub Optionbutton1_Change()
    If OptionButton1.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub Optionbutton2_Change()
    If OptionButton2.Value = True Then
        If ChangeSwitch = True Then
            保存忘れ防止装置
        End If
        ListIdx = 0
        氏名box
    End If
End Sub
Private Sub ListBox1_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    ListIdx = ListBox1.ListIndex
    Namae = ListBox1.List(ListIdx)
    l = Kensaku(ByVal Namae)
                  
    Call 個別へ表示(ByVal l)
End Sub
Private Sub CxBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    Rtn = MsgBox("転送せずに終了します。それでよければOKを押してください。", vbOKCancel)
    If Rtn = vbOK Then
        Unload Jyouken
        AboutForm.Show
    End If
End Sub
Private Sub ExitBtn_Click()
    If ChangeSwitch = True Then
        保存忘れ防止装置
    End If
    If Ranser = False Then
        Rtn = MsgBox("今まで行った変更を、ワークシートへ転送します。よろしければOKを押してください。", vbOKCancel)
        If Rtn = vbOK Then
            変更を保存して終了
           
            Unload Jyouken
            AboutForm.Show
        End If
       
    End If
    Ranser = False
End Sub
Private Sub CommandButton1_Click()
    Call 個別へ表示(ByVal l)
End Sub
Private Sub CommandButton2_Click()
    Dim Namae As String
    Dim MeNamae As Object
   
    OptionButton1.Value = False
    OptionButton2.Value = False
    Namae = TextBox1.Text
    Set MeNamae = Jyouken
    Call 検索(Namae, MeNamae)
End Sub
Sub 個別へ表示(ByVal l As Integer)
   
    With OldMember(l)
        Label31.Caption = .Simei4
        ComboBox18.Text = .TosekiJikan
        ComboBox10.Text = .Ryuryo
        ComboBox14.Text = .BAA
        ComboBox15.Text = .BAV
        ComboBox16.Text = .BAS
        ComboBox7.Text = .Dia
        ComboBox8.Text = .Hepa
        ComboBox9.Text = .LowHepa
        ComboBox11.Text = .PenRes(0)
        ComboBox12.Text = .PenRes(1)
        ComboBox13.Text = .PenRes(2)
       
        Select Case .iro
            Case 3 '赤
                ComboBox17.Text = "月水金AM"
                ComboBox17.BackColor = &HFF&
            Case 5 '青
                ComboBox17.Text = "月水金PM"
                ComboBox17.BackColor = &HFF0000
            Case 6 '黄
                ComboBox17.Text = "火木土AM"
                ComboBox17.BackColor = &HFFFF&
            Case 4 '緑
                ComboBox17.Text = "火木土PM"
                ComboBox17.BackColor = &HFF00&
            Case Else  '白、その他
                ComboBox17.Text = "その他"
                ComboBox17.BackColor = &HFFFFFF
        End Select
    End With
    ChangeSwitch = False
   
End Sub
Public Function Kensaku(ByVal Namae As String) As Integer
    Dim kensakuSu As Integer
   
    kensakuSu = 0
    For l = 0 To Maxl
        If OldMember(l).Simei1 = Namae Then
            kensakuSu = kensakuSu + 1
            If kensakuSu > 1 Then
                MsgBox ("透析患者リストの中に、同名で2件以上のデータがあります。不要なデータを削除して下さい。")
                Exit For
            End If
            Kensaku = l
        End If
    Next
End Function
Sub 保存忘れ防止装置()
    If ChangeSwitch = True Then
        ChangeSwitch = False
        Call 透析情報変数の更新(ByVal l)
    End If
End Sub
Sub 変更を保存して終了()
    Dim CelNo(3) As String
    Dim i As Integer
   
    l = 0
   
    Jyouken.Hide
   
    For i = 3 To MaxRows
        With OldMember(l)
            If .HenkoSwitch = True Then
           
               
                '透析クール(色)の転送
                    Touseki.Cells(i, 1).Activate
                    Touseki.Cells(i, 1).Interior.ColorIndex = .iro
                '名前(カナ)転送
                    Touseki.Cells(i, 3).Activate
                    Touseki.Cells(i, 3) = .Simei1
                'ヘパリンの転送
                    Touseki.Cells(i, 9).Activate
                    Touseki.Cells(i, 9) = .Hepa
                '低分子ヘパリンの転送
                    Touseki.Cells(i, 10).Activate
                    Touseki.Cells(i, 10) = .LowHepa
                '透析時間の転送
                    Touseki.Cells(i, 16).Activate
                    Touseki.Cells(i, 16) = .TosekiJikan
                '血液流量の転送
                    Touseki.Cells(i, 11).Activate
                    Touseki.Cells(i, 11) = .Ryuryo
                'ブラッドアクセスの転送
                    Touseki.Cells(i, 12).Activate
                    Touseki.Cells(i, 12) = .BAA
                    Touseki.Cells(i, 13).Activate
                    Touseki.Cells(i, 13) = .BAV
                    Touseki.Cells(i, 14).Activate
                    Touseki.Cells(i, 14) = .BAS
                'ダイアライザーの転送
                    Touseki.Cells(i, 15).Activate
                    Touseki.Cells(i, 15) = .Dia
               
                'ペンレスの転送
                    Touseki.Cells(i, 100).Activate
                    Touseki.Cells(i, 100) = .PenRes(0)
                    Touseki.Cells(i, 101).Activate
                    Touseki.Cells(i, 101) = .PenRes(1)
                    Touseki.Cells(i, 102).Activate
                    Touseki.Cells(i, 102) = .PenRes(2)
                   
            End If
            l = l + 1
        End With
    Next
   
    MsgBox ("データの転送が終了しました")
   
End Sub
Sub 透析情報変数の更新(ByVal l As Integer)

    With OldMember(l)
        .HenkoSwitch = True
        .TosekiJikan = ComboBox18.Text
        .Ryuryo = ComboBox10.Text
        .BAA = ComboBox14.Text
        .BAV = ComboBox15.Text
        .BAS = ComboBox16.Text
        .Dia = ComboBox7.Text
        .Hepa = ComboBox8.Text
        .LowHepa = ComboBox9.Text
        .PenRes(0) = ComboBox11.Text
        .PenRes(1) = ComboBox12.Text
        .PenRes(2) = ComboBox13.Text
        .iro = Tcolor
    End With
End Sub
Sub 透析条件テンプ作成()
    Dim Tempulist As Object
    Dim Tate As Integer
    Dim Yoko As Integer
   
    Set Tempulist = Worksheets("テンプレート集")
       
    '血液流量
    Tate = 3
    Yoko = 6
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox10.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '透析時間
    Tate = 3
    Yoko = 12
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox18.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ブラッドアクセスA
    Tate = 3
    Yoko = 7
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox14.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ブラッドアクセスV
    Tate = 3
    Yoko = 8
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox15.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ブラッドアクセスS
    Tate = 3
    Yoko = 9
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox16.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ダイアライザ
    Tate = 3
    Yoko = 10
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox7.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ヘパリン
    Tate = 3
    Yoko = 4
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox8.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '低分子ヘパリン
    Tate = 3
    Yoko = 5
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox9.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    'ペンレス
    Tate = 3
    Yoko = 11
    Do
        Tempu = Tempulist.Cells(Tate, Yoko)
        ComboBox11.AddItem (Tempu)
        ComboBox12.AddItem (Tempu)
        ComboBox13.AddItem (Tempu)
        Tate = Tate + 1
    Loop While Tempu <> ""
   
    '透析クール
    With ComboBox17
        .AddItem ("月水金AM")
        .AddItem ("月水金PM")
        .AddItem ("火木土AM")
        .AddItem ("火木土PM")
        .AddItem ("その他")
    End With
End Sub
Private Sub ComboBox10_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox11_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox12_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox13_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox14_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox15_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox16_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox17_Change()
    ChangeSwitch = True
    Select Case ComboBox17.ListIndex
    Case 0 '赤
        Tcolor = 3
        ComboBox17.BackColor = &HFF&
    Case 1 '青
        Tcolor = 5
        ComboBox17.BackColor = &HFF0000
    Case 2 '黄
        Tcolor = 6
        ComboBox17.BackColor = &HFFFF&
    Case 3 '緑
        Tcolor = 4
        ComboBox17.BackColor = &HFF00&
    Case Else  '白、その他
        Tcolor = 2
        ComboBox17.BackColor = &HFFFFFF
End Select
End Sub
Private Sub ComboBox18_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox7_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox8_Change()
    ChangeSwitch = True
End Sub
Private Sub ComboBox9_Change()
    ChangeSwitch = True
End Sub


追記を閉じる▲

【2008/03/12 12:36】 | エクセルVBAで作った透析データベース
トラックバック(0) |