| |
>選択という意味が善く解らないのですが？
レコードの上下移動と言う意味でしょうか？
レコードの項目は違いますが、過去に作ったUserFormのコードが有りますので、
参考に成るかどうか見て下さい
尚、Noは昇順に並んでいることが条件です
探索の開始は、TextBox1のExitイベントで番号を探します
また、TextBox1に無い番号を入れた場合、新規入力に成り
例えば、10番、12番が存在する時、11番を指定すると10番、12番の間に行が挿入され11番が書きこまれます
UserFormの配置は、
TextBox1〜4
CommandButton1 入力（UserFormからセルに書き込み）
CommandButton2 削除（現在表示されている番号の行を削除）
CommandButton3 ↑移動
CommandButton4 ↓移動
を想定しています
以下のコードをUserFormモジュールに記入
Option Explicit
'Listの列数
Private Const clngColumns As Long = 7
'探索Keyの有る列位置(基準位置からの列Offset)
Private Const clngKeys As Long = 0
'Listの先頭、最左の列見出しのセル位置
Private rngList As Range
'Listの行数
Private lngRows As Long
'操作対象行位置
Private lngCurrent As Long
'存在Flag(0以外は、該当Keyが存在する)
Private lngFound As Long
Private Sub UserForm_Initialize()
'Listの先頭セル位置を基準として設定(最左の列見出しのセル位置)
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'Listのデータ行数取得
lngRows = .Offset(Rows.Count - .Row, clngKeys).End(xlUp).Row - .Row
If lngRows < 0 Then
lngRows = 0
End If
End With
'スクロールバーの初期化
With ScrollBar1
.Max = lngRows
.Min = 1
.TabStop = False
.LargeChange = 10
End With
End Sub
Private Sub UserForm_Activate()
'コントロールの初期化
ControlsInitialize
'データ範囲にデータが有るなら
If lngRows > 0 Then
'操作行を先頭行に
lngCurrent = 1
'存在行を先頭行に
lngFound = 1
'スクロールバーを先頭行に設定
ScrollBar1.Value = lngCurrent
RowUpDown
Else
'操作行を未定に
lngCurrent = 0
'存在行を未定に
lngFound = 0
End If
End Sub
Private Sub UserForm_Terminate()
Set rngList = Nothing
End Sub
Private Sub CommandButton1_Click()
' データを転記
Dim i As Long
'操作行が未定なら
If lngCurrent = 0 Then
Exit Sub
End If
'探索Keyが存在するなら
If lngFound > 0 Then
'データの上書き
SetData lngCurrent
Else
'作成行がデータ範囲内なら
If lngCurrent <= lngRows Then
rngList.Offset(lngCurrent).EntireRow.Insert
End If
'List行数をインクリメント
lngRows = lngRows + 1
'スクロールバーの範囲を更新
ScrollBar1.Max = lngRows
'挿入位置にデータの転記
SetData lngCurrent
End If
'存在行を操作行に
lngFound = lngCurrent
End Sub
Private Sub CommandButton2_Click()
' 該当行を削除
Dim i As Long
If lngFound > 0 And lngCurrent > 0 Then
Beep
If MsgBox("Key " & TextBox1.Text & " のDataを削除します", _
vbExclamation + vbOKCancel, "削除") = vbOK Then
'操作行を削除
rngList.Offset(lngCurrent).EntireRow.Delete
'List行数をディクリメント
lngRows = lngRows - 1
'スクロールバーの範囲を更新
ScrollBar1.Max = lngRows
'データ行が有るなら
If lngRows > 0 Then
'次のデータを表示
RowUpDown
'存在行を操作行に
lngFound = lngCurrent
Else
'操作行を未定に
lngCurrent = 0
'存在行を未定に
lngFound = 0
'コントロールの初期化
ControlsInitialize
End If
End If
End If
End Sub
Private Sub CommandButton3_Click()
' 行のDouwn
lngCurrent = lngCurrent - 1
RowUpDown
End Sub
Private Sub CommandButton4_Click()
' 行のUp
lngCurrent = lngCurrent + 1
RowUpDown
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 ScrollBar1_Change()
lngCurrent = ScrollBar1.Value
RowUpDown
End Sub
Private Sub TextBox1_Enter()
'コントロールの初期化
ControlsInitialize
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
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(CLng(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
'コントロールの初期化
ControlsInitialize
TextBox1.Text = vntKey
Beep
If MsgBox("該当するレコードが有りませんので新規作成します", _
vbExclamation + vbOKCancel, "新規入力") = vbOK Then
'操作行を行挿入位置に設定
lngCurrent = lngOver
CommandButton1.Enabled = True
Else
'操作行を未定に
lngCurrent = 0
Cancel = True
End If
End If
Else
'操作行を未定に
lngCurrent = 0
'存在行を未定に
lngFound = 0
End If
End With
End Sub
Private Sub ControlsInitialize()
' 各コントロールの初期化
Dim i As Long
CommandButton1.Enabled = False
CommandButton2.Enabled = False
For i = 1 To 5
Me.Controls("TextBox" & i).Text = ""
Next i
OptionButton1.Value = True
TextBox6.Text = ""
End Sub
Private Sub GetData(lngRow As Long)
' 1行分のListデータを各コントロールに代入
Dim i As Long
Dim vntData As Variant
With rngList.Offset(lngRow)
.Activate
'データを1行分、配列に取得
vntData = .Resize(, clngColumns).Value
End With
'配列のデータを各コントロールに代入
For i = 1 To 5
Controls("TextBox" & i).Text = vntData(1, i)
Next i
With Frame1
For i = 0 To .Controls.Count - 1
If .Controls(i).Caption = CStr(vntData(1, 6)) Then
.Controls(i).Value = True
Exit For
End If
Next i
If i > .Controls.Count - 1 Then
.Controls(0).Value = True
End If
End With
TextBox6.Text = Format(vntData(1, 7), "ggge年m月d日")
CommandButton1.Enabled = True
CommandButton2.Enabled = True
'スクロールバーの表示位置更新
With ScrollBar1
If .Value <> lngRow Then
.Value = lngRow
End If
End With
End Sub
Private Sub SetData(lngRow As Long)
' 各コントロールデータを1行分のListに代入
Dim i As Long
Dim vntData As Variant
'1行分の出力用配列を確保
ReDim vntData(1 To 1, 1 To clngColumns)
'各コントロールの値を配列に代入
For i = 1 To 5
vntData(1, i) = Controls("TextBox" & i).Text
Next i
vntData(1, 6) = Frame1.Tag
vntData(1, 7) = TextBox6.Text
With rngList.Offset(lngRow)
.Activate
'配列を出力
.Resize(, clngColumns).Value = vntData
End With
'スクロールバーの表示位置更新
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
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
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
'操作行を最終行に
lngCurrent = lngRows
ElseIf lngCurrent < 1 Then
'操作行を先頭行に
lngCurrent = 1
End If
'存在行を操作行に
lngFound = lngCurrent
'コントロールに値読み込み
GetData lngCurrent
TextBox2.SetFocus
End Sub
尚、データは下記の物を想定しています
ID 氏名 郵便番号 住所 電話番号 性別 生年月日
1 山田 敬司 1120012 東京都文京区大塚X-XX-X 035978xxxx 男 昭和35年1月30日
2 木下 美絵 1790072 東京都練馬区光が丘X-X-X-XX 033976XXXX 女 昭和61年12月30日
4 篠ｳ 望人 1920907 東京都八王子市長沼町XXX-XX 042636xxxx 男 昭和49年9月25日
|
|
Hirofumi
- 06/9/17(日) 21:00 -
