【広告】

しのちーチャンネル

エクセルマクロで作った透析データベース~保険番号フォーム

各患者さんの保険番号を管理するためのフォームです。

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

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

 保険番号フォーム


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
 &
nbsp;          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
              &
nbsp; 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

コメント

タイトルとURLをコピーしました