| |
私だったらこんな形にします
データー閲覧用、入力用区別は有りません同じ物です
ただ、全文は、サイトの上限文字数を超えてしまうので
「入院・外来」所までとしています
UserFormのコントロールは、ReginaさんのUserForm4の構成に
以下のコントロールを追加して下さい
CommandButton1：入力ボタン
CommandButton2：行削除ボタン
ScrollBar1：レコード移動用
尚、レコード移動は、＜前 →CommandButton9、次＞ →CommandButton10の他に
ScrollBar1で行うのと、TextBox1に「患者ID」を入力してフォーカスを移動すると
患者IDが有れば、そのレコードに移動しますし、無ければ新規レコード位置に移動します
'UserFormのコード
Option Explicit
'探索Keyの有る列位置(基準位置からの列Offset)
Private Const clngKeys As Long = 0
'入力モードと表示モードの切り替え
Public blnInput As Boolean
'Listの先頭、最左の列見出しのセル位置
Private rngList As Range
'Listの行数(最終行)
Private lngRows As Long
'操作対象行位置(表示行)
Private lngCurrent As Long
'IDの最大値
Private lngMaxNum As Long
Private Sub UserForm_Initialize()
TextBox1.TabStop = False
'Listの先頭セル位置を基準として設定(最左の列見出しのセル位置:[患者ＩＤ])
Set rngList = Worksheets("Sheet1").Cells(4, "A")
With rngList
.Parent.Activate
'Listのデータ行数取得
lngRows = .Offset(Rows.Count - .Row, clngKeys).End(xlUp).Row - .Row
If lngRows <= 0 Then
lngRows = 0
lngMaxNum = 0
Else
lngMaxNum = Application.WorksheetFunction _
.Max(.Offset(1).Resize(lngRows))
End If
End With
'スクロールバーの初期化
With ScrollBar1
.Max = lngRows + 1
.Min = 1
.TabStop = False
.LargeChange = 5
End With
End Sub
Private Sub UserForm_Activate()
'入力フォーム指定なら
If blnInput Then
'入力ボタン、削除ボタンを使用可に
CommandButton1.Enabled = True
CommandButton2.Enabled = True
'データ範囲にデータが有るなら
If lngRows > 0 Then
'操作行を最終行+1に
lngCurrent = lngRows + 1
'スクロールバーを操作行に設定
ScrollBar1.Value = lngCurrent
Else
'操作行を先頭行に
lngCurrent = 1
GetData lngCurrent
End If
Else
'入力ボタン、削除ボタンを使用不可に
CommandButton1.Enabled = False
CommandButton2.Enabled = False
'操作行を先頭行に
lngCurrent = 1
GetData lngCurrent
End If
End Sub
Private Sub UserForm_Terminate()
Set rngList = Nothing
End Sub
Private Sub OptionButton1_Click()
With OptionButton1
.Parent.Tag = .Caption
End With
End Sub
Private Sub OptionButton2_Click()
With OptionButton2
.Parent.Tag = .Caption
End With
End Sub
Private Sub OptionButton3_Click()
With OptionButton3
.Parent.Tag = .Caption
End With
End Sub
Private Sub OptionButton4_Click()
With OptionButton4
.Parent.Tag = .Caption
End With
End Sub
Private Sub CommandButton1_Click()
' データを転記
Dim i As Long
'書き換えが、データ範囲内なら
If lngCurrent > lngRows Then
'List行数をインクリメント
lngRows = lngRows + 1
'スクロールバーの範囲を更新
ScrollBar1.Max = lngRows + 1
End If
'シートにデータの転記
SetData lngCurrent
'新規入力位置を表示
lngCurrent = lngRows + 1
GetData lngCurrent
End Sub
Private Sub CommandButton2_Click()
' 該当行を削除
Dim i As Long
If lngCurrent <= lngRows Then
Beep
If MsgBox("Key " & TextBox1.Text & " のDataを削除します", _
vbExclamation + vbOKCancel, "削除") = vbOK Then
'操作行を削除
rngList.Offset(lngCurrent).EntireRow.Delete
'List行数をディクリメント
lngRows = lngRows - 1
'スクロールバーの範囲を更新
ScrollBar1.Max = lngRows + 1
'データ行が有るなら
If lngRows > 0 Then
'次のデータを表示
RowUpDown
Else
'操作行を最終行に
lngCurrent = lngRows + 1
'コントロールに値読み込み
GetData lngCurrent
End If
End If
End If
End Sub
Private Sub CommandButton9_Click()
' 行のDouwn
lngCurrent = lngCurrent - 1
RowUpDown
End Sub
Private Sub CommandButton10_Click()
' 行のUp
lngCurrent = lngCurrent + 1
RowUpDown
End Sub
Private Sub CommandButton11_Click()
Unload Me
End Sub
Private Sub ScrollBar1_Change()
lngCurrent = ScrollBar1.Value
RowUpDown
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'存在Flag(0以外は、該当Keyが存在する)
Dim lngFound As Long
Dim lngOver As Long
Dim vntKey As Variant
With TextBox1
If .Text <> "" Then
'探索Keyを取得
vntKey = .Text
'Listにデータ行が有るなら
If lngRows > 0 Then
'Listから該当するKeyの行を探索(探索Keyが数値の場合)
lngFound = RowSearch(Val(vntKey), rngList.Offset(1, _
clngKeys).Resize(lngRows), lngOver)
'Listから該当するKeyの行を探索(探索Keyが文字列の場合)
' lngFound = RowSearch(vntKey, rngList.Offset(1, _
clngKeys).Resize(lngRows), lngOver)
Else
lngFound = 0
lngOver = 1
End If
'探索Keyの該当行が有る場合
If lngFound > 0 Then
'操作行を存在行に
lngCurrent = lngFound
'コントロールに値読み込み
GetData lngCurrent
Else
'操作行を行挿入位置に設定
lngCurrent = lngOver
'コントロールに値読み込み
GetData lngCurrent
TextBox1.Text = vntKey
End If
Else
'操作行を最終行+1位置に設定
lngCurrent = lngRows + 1
'コントロールに値読み込み
GetData lngCurrent
TextBox1.Text = lngMaxNum + 1
End If
End With
End Sub
Private Sub GetData(lngRow As Long)
' 1行分のListデータを各コントロールに代入
With rngList.Offset(lngRow)
.Activate
If lngRow <= lngRows Then
TextBox1.Text = .Offset(, 0).Value
Else
TextBox1.Text = lngMaxNum + 1
End If
TextBox2.Text = .Offset(, 1).Value
Frame8.Tag = .Offset(, 2).Value
SetOptionValue Frame8
TextBox3.Text = .Offset(, 3).Value
TextBox4.Text = .Offset(, 4).Value
Frame2.Tag = .Offset(, 5).Value
SetOptionValue Frame2
End With
'スクロールバーの表示位置更新
With ScrollBar1
If .Value <> lngRow Then
.Value = lngRow
End If
End With
TextBox2.SetFocus
End Sub
Private Sub SetData(lngRow As Long)
' 各コントロールデータを1行分のListに代入
With rngList.Offset(lngRow)
.Offset(, 0).Value = TextBox1.Text
.Offset(, 1).Value = TextBox2.Text
.Offset(, 2).Value = Frame8.Tag
.Offset(, 3).Value = TextBox3.Text
.Offset(, 4).Value = TextBox4.Text
.Offset(, 5).Value = Frame2.Tag
End With
'IDが最大値を超す場合、最大値を書き換え
If lngMaxNum < Val(TextBox1.Text) Then
lngMaxNum = Val(TextBox1.Text)
End If
'スクロールバーの表示位置更新
With ScrollBar1
If .Value <> lngRow Then
.Value = lngRow
End If
End With
End Sub
Private Function RowSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long) As Long
Dim vntFind As Variant
If rngScope Is Nothing Then
lngOver = 1
Exit Function
End If
lngOver = rngScope.Rows.Count + 1
'Matchによる探索
vntFind = Application.Match(vntKey, rngScope, 0)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'戻り値として、行位置を代入
RowSearch = vntFind
End If
End Function
Private Sub RowUpDown()
' 行のUP、Douwn
'LIst範囲にデータが無い場合
If lngRows < 1 Then
lngCurrent = 0
Exit Sub
End If
'操作行が、LIst範囲を超えるなら
If lngCurrent > lngRows Then
'操作行を最終行+1に
lngCurrent = lngRows + 1
ElseIf lngCurrent < 1 Then
'操作行を先頭行に
lngCurrent = 1
End If
'コントロールに値読み込み
GetData lngCurrent
End Sub
Private Sub SetOptionValue(fraObject As MSForms.Frame)
' 文字列とOptionButtonのCaptionが同じ場合、OptionButtonをTrueにする
Dim i As Long
Dim vntValue As Variant
'Frameに就いて
With fraObject
'与えられた文字列に区切り文字を追加
vntValue = .Tag
'Frame内のControlに就いて繰り返し
For i = 0 To .Controls.Count - 1
'ControlがOptionButtonであるなら
If TypeName(.Controls(i)) = "OptionButton" Then
'同じ場合
If vntValue = .Controls(i).Caption Then
'OptionButtonをTrueに
.Controls(i).Value = True
Exit For
End If
End If
Next i
'該当がない場合
If i > .Controls.Count - 1 Then
For i = 0 To .Controls.Count - 1
'先頭のOptionButtonを
If TypeName(.Controls(i)) = "OptionButton" Then
'Trueに
.Controls(i).Value = True
Exit For
End If
Next i
End If
End With
End Sub
UserFormを呼び出すコード（標準モジュール）
Public Sub ViewOnly()
With UserForm1
.blnInput = False
.Show
End With
End Sub
Public Sub InputForm()
With UserForm1
.blnInput = True
.Show
End With
End Sub
|
|
Hirofumi
- 08/3/30(日) 0:56 -
