透析条件を編集するためのフォームです。透析条件とは透析時間から始まって使う機材の名前や針を刺す場所などの重要なデーターです。
選択して入力できるようにするためにコンボボックスやリストボックスを多用しております。コンボボックスやリストボックスのリスト一覧をエクセルのワークシート テンプレート集 から読み込みます。
患者さんの氏名を検索してその人の透析条件を表示させます。条件を編集したら元のエクセルのワークシートへ転送します。
氏名の検索は以前このブログで取り上げさせていただきました検索窓をすべてのフォーム共通で使っております。
エクセルVBAで検索窓を作る
エクセルのワークシートを使ったデータベースです。ワークシートからデーターを読み込みまた変更したものをワークシートへ転送します。
下のフォームは透析条件編集フォームです。
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 ("透析患者リストの中に、同名で２件以上のデータがあります。不要なデータを削除して下さい。")
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)
&nb
sp; 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 <&
gt; ""
‘ブラッドアクセス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
コメント