Excel VBA質問箱 IV

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

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


41967 / 76736 ←次へ | 前へ→

【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

0 hits

【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 お礼

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