Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

7319 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

▼

【39836】検索該当なしの場合の登録について 勉強中です 06/7/2(日) 19:21

【39837】Re:検索該当なしの場合の登録について Hirofumi 06/7/2(日) 19:59

【39838】Re:検索該当なしの場合の登録について Hirofumi 06/7/2(日) 20:32

【39839】Re:検索該当なしの場合の登録について 勉強中です 06/7/2(日) 20:50

【39840】Re:検索該当なしの場合の登録について Hirofumi 06/7/2(日) 21:06

【39841】Re:検索該当なしの場合の登録について 勉強中です 06/7/2(日) 21:12

【39843】Re:検索該当なしの場合の登録について Hirofumi 06/7/2(日) 21:33

【39844】Re:検索該当なしの場合の登録について 勉強中です 06/7/2(日) 21:42

【39861】Re:検索該当なしの場合の登録について 勉強中です 06/7/3(月) 13:10


	【39836】検索該当なしの場合の登録について

勉強中です

- 06/7/2(日) 19:21 -


	引用なし

	パスワード

みなさん　こんばんわ　
いつもお世話になっております
今回は、
　　　　Ａ　　　　Ｂ　　　　　Ｃ　　　Ｄ　　・・・・　Ｌ

１　　１列目はタイトル

２　１２３　　　空白　　　空白　　　文字　　Ｅ～Ｋは数字です
　　　　　　　　　　　　　　　　　　　　　Ｌは文字

というデーターからユーザーフォームを使用してＡ列で検索をして
該当があればテキストボックスに値が反映されますそれを変更して
コマンドボタンで登録をしています。
該当がなかった場合にデーターの最終行の次の行にフォームの内容が
貼付けられる様にするにはどうしたらいいのでしょうか
ヒントでもいただけるとうれしいです　
効率の悪いコードですが載せておきます

Private Sub CommandButton1_Click()
'テキストボックスの値を各セルに貼付け
For i = 1 To Range("A65536").End(xlUp).Row
　　　　If Cells(i, 1) = TextBox1 Then
　　　　　　Cells(i, 2) = TextBox5.Value
　　　　　　Cells(i, 3) = TextBox3.Value
　　　　　　Cells(i, 4) = TextBox4.Value
　　　　　　Cells(i, 5) = TextBox2.Value
　　　　　　Cells(i, 6) = TextBox6.Value
　　　　　　Cells(i, 7) = TextBox7.Value
　　　　　　Cells(i, 8) = TextBox8.Value
　　　　　　Cells(i, 9) = TextBox9.Value
　　　　　　Cells(i, 10) = TextBox10.Value
　　　　　　Cells(i, 11) = TextBox11.Value
　　　　　　End If
　　　　
　　　 Next i
　　　　　　　Dim s As Long
　　　　　　Const r As Long = 12
　　　　　　
　　For s = 1 To r
　　　　Controls("TextBox" & s).Text = ""
　　Next s
　

　　TextBox1.SetFocus

End Sub

Private Sub TextBox1_Change()
　　
　　
　Dim a As String
　Dim r As String
　Dim i As Integer
　　
　　a = TextBox1.Text

　　For i = 1 To Range("A65536").End(xlUp).Row
　　　　 r = Range("A" & i).Value
　　　　If a = r Then
　　　　　　TextBox2.Value = Range("A" & i).Offset(0, 4).Value
　　　　　　TextBox3.Value = StrConv(TextBox2.Value, vbKatakana + vbNarrow)
　　　　　　TextBox4.Value = StrConv(TextBox2.Value, vbKatakana + vbNarrow)
　　　　　　TextBox5.Value = Range("A" & i).Offset(0, 1).Value
　　　　　　TextBox6.Value = Range("A" & i).Offset(0, 5).Value
　　　　　　TextBox7.Value = Range("A" & i).Offset(0, 6).Value
　　　　　　TextBox8.Value = Range("A" & i).Offset(0, 7).Value
　　　　　　TextBox9.Value = Range("A" & i).Offset(0, 8).Value
　　　　　　TextBox10.Value = Range("A" & i).Offset(0, 9).Value
　　　　　　TextBox11.Value = Range("A" & i).Offset(0, 10).Value
　　　　　　TextBox12.Value = Range("A" & i).Offset(0, 11).Value
　　　　End If
　　Next i
　　
TextBox1.SetFocus
　　
End Sub
　　　　


	【39837】Re:検索該当なしの場合の登録について

Hirofumi - 06/7/2(日) 19:59 -


	引用なし

	パスワード

昔作った物で、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


	【39838】Re:検索該当なしの場合の登録について

Hirofumi - 06/7/2(日) 20:32 -


	引用なし

	パスワード

後もし、A列の値が数値の場合の変更を補足して置きます

以下の★印に変更して下さい
「Private Sub CommandButton1_Click()」の中の

　　If lngCurrent = 0 Then
　　　　'読み仮名、ID等のセル範囲からTextBox1値の行挿入位置を探索
'　　　　lngFound = RowSearch(TextBox1.Text, rngSearch, lngOver)
　　　　lngFound = RowSearch(Val(TextBox1.Text), rngSearch, lngOver) '★変更
　　　　'行挿入位置がList範囲内なら

「Private Sub TextBox1_AfterUpdate()」の中の

　　　　　　'TextBoxの値を半角大文字に揃える
'　　　　　　.Text = StrConv(.Text, vbNarrow + vbUpperCase)
　　　　　　'読み仮名、ID等のセル範囲からTextBox1値を探索、現在行を探索位置に
'　　　　　　lngCurrent = RowSearch(.Text, rngSearch)
　　　　　　lngCurrent = RowSearch(Val(.Text), rngSearch) '★変更
　　　　　　'もし、読み仮名、ID等が有った場合

詰まり、TextBox1の値を数値に直して、「Private Function RowSearch」の引数として与えます

また、以下の★印の部分で、A列のセル書式を「文字列」にしてしまう為
此れを止めて下さい

「Private Sub PutCellsData(lngRow As Long)」の中の

　　With rngList
　　　　'読み仮名、ID等を文字列として扱う時は、この行が必要
'　　　　.Offset(lngRow).NumberFormatLocal = "@" '★削除若しくはコメントアウト
　　　　For i = 1 To lngColumns


	【39839】Re:検索該当なしの場合の登録について

勉強中です

- 06/7/2(日) 20:50 -


	引用なし

	パスワード

Hirofumiさん　こんばんは
早速のお返事ありがとうございます
すみません　私には難解なコードでよく理解していないのですが
すばらしい内容です。　
１つだけ教えていただきたいのですが
これだと自動でコードがソートされて所定の位置に行が挿入されて
新規のデーターが入りますがこれを入力行の一番下にすることは出来ませんか
わがままですみません


	【39840】Re:検索該当なしの場合の登録について

Hirofumi - 06/7/2(日) 21:06 -


	引用なし

	パスワード

▼勉強中ですさん：
>Hirofumiさん　こんばんは
>早速のお返事ありがとうございます
>すみません　私には難解なコードでよく理解していないのですが
>すばらしい内容です。　
>１つだけ教えていただきたいのですが
>これだと自動でコードがソートされて所定の位置に行が挿入されて
>新規のデーターが入りますがこれを入力行の一番下にすることは出来ませんか
>わがままですみません

現状のコードでは、出来ません
理由は、行探索の速度を上げるため「Private Function RowSearch」で
使っている、Match関数の第３引数に「1」を指定している事によります
因って、探索列の昇順整列が必須と成ります

もし、「入力行の一番下」にデータを入れる場合
「Private Function RowSearch」の中身のの変更と
「Private Function RowSearch」を使っている部分の変更が必要と成ります


	【39841】Re:検索該当なしの場合の登録について

勉強中です

- 06/7/2(日) 21:12 -


	引用なし

	パスワード

hirofumiさん　ありがとうございます
何とかがんばって見ます変更のあったセルの色付けかなにかで
判別をして見ます。
また何かありましたらお願いいたします。


	【39843】Re:検索該当なしの場合の登録について

Hirofumi - 06/7/2(日) 21:33 -


	引用なし

	パスワード

もう見て居ないかな？

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


	【39844】Re:検索該当なしの場合の登録について

勉強中です

- 06/7/2(日) 21:42 -


	引用なし

	パスワード

Hirofumiさん　こんばんは
重ね重ねありがとうございます。
本日はこれで退社しなければならないので
明日に試してご報告いたします。


	【39861】Re:検索該当なしの場合の登録について

勉強中です

- 06/7/3(月) 13:10 -


	引用なし

	パスワード

Hirofumiさん　こんにちは
ありがとうございます。
完璧に動きました
とてもすばらしいコードで今後イロイロな場面で活用
させていただきます。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

7319 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free