エクセルマクロで作った透析データベース～日付フォーム

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

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

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 To
useki = 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 = WeekdayNam
e(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