| |
昔作った物で、TextBoxが8個で少し質問と違いますが？
こんな物かな？
UserFormには、TextBoxが8個、CommandButtonが2個有る物とします
CommandButton1は、データの追加、更新とします
CommandButton2は、データの削除とします
TextBox1は、読み仮名、ID等の入力とします
読み仮名、ID等が入力された場合、読み仮名、ID等列（A列）を探索し
読み仮名、ID等が該当する場合、TextBoxにListからデータを読み込み、更新モードと成ります
読み仮名、ID等の該当が無い場合、追加モードと成り、
「追加、更新」ボタンで挿入位置に行が挿入されデータが書きこまれます
「削除」ボタンは、TextBoxに現在表示されている行を削除します
尚、読み仮名、ID等列は、数値と文字列を混在させると上手く動きません、
必ずどちらかに揃えて下さい（現在のコードでは、追加した読み仮名、ID等は、文字列と成ります）
また、読み仮名、ID等列は、常に昇順に並べられます(Matchの最終引数を1としたい為)
Option Explicit
'Listの列数
Const lngColumns As Long = 8
'Listの先頭セル位置
Private rngList As Range
'読み仮名、ID等のセル範囲
Private rngSearch As Range
'Listの行数
Private lngRows As Long
'Listの現在行(Offset値)
Private lngCurrent As Long
Private Sub CommandButton1_Click()
' 行の追加、更新
Dim lngFound As Long
Dim lngOver As Long
If TextBox1.Text = "" Then
Exit Sub
End If
'現在行が未定なら
If lngCurrent = 0 Then
'読み仮名、ID等のセル範囲からTextBox1値の行挿入位置を探索
lngFound = RowSearch(TextBox1.Text, rngSearch, lngOver)
'行挿入位置がList範囲内なら
If lngOver <= lngRows Then
'行を挿入
rngList.Offset(lngOver).EntireRow.Insert
End If
'現在行を挿入位置に設定
lngCurrent = lngOver
'List行数をインクリメント
lngRows = lngRows + 1
'読み仮名、ID等のセル範囲を更新
Set rngSearch = rngList.Offset(1).Resize(lngRows)
End If
'TextBoxの値を現在行に出力
PutCellsData lngCurrent
End Sub
Private Sub CommandButton2_Click()
' 行の削除
Dim lngWrite As Long
'現在行が未定なら
If lngCurrent = 0 Then
Exit Sub
Else
If MsgBox(TextBox1.Text & "のデータが削除されます", _
vbExclamation + vbOKCancel, "行削除") = vbOK Then
With rngList.Offset(lngCurrent)
'名簿Listの削除行を削除
.EntireRow.Delete
End With
End If
'List行数をディリメント
lngRows = lngRows - 1
'読み仮名、ID等のセル範囲を更新
Set rngSearch = rngList.Offset(1).Resize(lngRows)
End If
'TextBoxのデータをクリア
TextBox1.Text = ""
DataClear
End Sub
Private Sub TextBox1_AfterUpdate()
With TextBox1
If .Text <> "" Then
'TextBoxの値を半角大文字に揃える
' .Text = StrConv(.Text, vbNarrow + vbUpperCase)
'読み仮名、ID等のセル範囲からTextBox1値を探索、現在行を探索位置に
lngCurrent = RowSearch(.Text, rngSearch)
'もし、読み仮名、ID等が有った場合
If lngCurrent > 0 Then
'TextBoxにListの値を読み込み
GetCellsData lngCurrent
Else
'TextBoxをクリア
DataClear
End If
Else
'現在行を未定に設定
lngCurrent = 0
End If
End With
End Sub
Private Sub UserForm_Initialize()
'Listの先頭位置を設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'Listの行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'読み仮名、ID等のセル範囲を取得
If lngRows > 0 Then
Set rngSearch = .Offset(1).Resize(lngRows)
End If
End With
'現在行を0に設定
lngCurrent = 0
End Sub
Private Sub UserForm_Terminate()
Set rngList = Nothing
Set rngSearch = Nothing
End Sub
Private Sub GetCellsData(lngRow As Long)
' TextBoxにデータの読み込み
Dim i As Long
With rngList
For i = 2 To lngColumns
Controls("TextBox" & i).Text = .Offset(lngRow, i - 1).Value
Next i
End With
End Sub
Private Sub PutCellsData(lngRow As Long)
' Listにデータの出力
Dim i As Long
With rngList
'読み仮名、ID等を文字列として扱う時は、この行が必要
.Offset(lngRow).NumberFormatLocal = "@"
For i = 1 To lngColumns
.Offset(lngRow, i - 1).Value = Controls("TextBox" & i).Text
Next i
End With
TextBox1.Text = ""
DataClear
End Sub
Private Sub DataClear()
' TextBoxのデータクリア
Dim i As Long
For i = 2 To lngColumns
Controls("TextBox" & i).Text = ""
Next i
lngCurrent = 0
TextBox1.SetFocus
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
|
|
Hirofumi
- 06/7/2(日) 19:59 -
