Excel VBA質問箱 IV

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

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


7317 / 13644 ツリー ←次へ | 前へ→

【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】検索該当なしの場合の登録について
質問  勉強中です E-MAIL  - 06/7/2(日) 19:21 -

引用なし
パスワード
   みなさん こんばんわ 
いつもお世話になっております
今回は、
    A    B     C   D  ・・・・ L

1  1列目はタイトル

2 123   空白   空白   文字  E〜Kは数字です
                     Lは文字

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

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:検索該当なしの場合の登録について
お礼  勉強中です E-MAIL  - 06/7/2(日) 20:50 -

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

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

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

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

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

【39841】Re:検索該当なしの場合の登録について
お礼  勉強中です E-MAIL  - 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:検索該当なしの場合の登録について
お礼  勉強中です E-MAIL  - 06/7/2(日) 21:42 -

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

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

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

7317 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free