エクセルマクロで作った透析データベース～個別情報編集

患者さんの氏名や生年月日、血液型などを修正するためのフォームです。

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

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
 &nbsp
;  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 ("透析患者リストの中に、同名で２件以上のデータがあります。不要なデータを削除して下さい。")
                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
                ‘ＲＨ（血液型）の転送
                Touseki.Cells(i, 8).Activate< br />                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_Ch
ange()
    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