Excel VBA質問箱 IV

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

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


41969 / 76732 ←次へ | 前へ→

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

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