| |
もう見て居ないかな？
Testして居ないので、上手く行かないかも知れませんが？
A列の非整列版（行末追加版）
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
If TextBox1.Text = "" Then
Exit Sub
End If
'現在行が未定なら
If lngCurrent = 0 Then
'読み仮名、ID等のセル範囲からTextBox1値の行挿入位置を探索
' lngFound = RowSearch(TextBox1.Text, rngSearch)
lngFound = RowSearch(Val(TextBox1.Text), rngSearch) '★変更
'探索値が無いなら
If lngFound = 0 Then
'書きこみ位置を行末+1に
lngCurrent = lngRows + 1
'List行数をインクリメント
lngRows = lngRows + 1
'読み仮名、ID等のセル範囲を更新
Set rngSearch = rngList.Offset(1).Resize(lngRows)
Else
'探索位置を現在行に設定
lngCurrent = lngFound
End If
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)
lngCurrent = RowSearch(Val(.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) As Long
Dim vntFind As Variant
If rngScope Is Nothing Then
Exit Function
End If
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 0)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'戻り値として、行位置を代入
RowSearch = vntFind
End If
End Function
|
|
Hirofumi
- 06/7/2(日) 21:33 -
