Excel VBA質問箱 IV

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

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


56982 / 76732 ←次へ | 前へ→

【24491】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 7:16 -

引用なし
パスワード
   フォームというのがUserFormならこんな形かな?
UserFormには、TextBoxが7個、CommandButtonが2個有る物とします
CommandButton1は、データの追加、更新とします
CommandButton2は、データの削除とします
TextBox1は、IDの入力とします
IDが入力された場合、ID列(A列)を探索し
IDが該当する場合、TextBoxにListからデータを読み込み、更新モードと成ります
IDの該当が無い場合、追加モードと成り、
「追加、更新」ボタンで挿入位置に行が挿入されデータが書きこまれます
「削除」ボタンは、TextBoxに現在表示されている行を削除します
尚、ID列は、数値と文字列を混在させると上手く動きません、
必ずどちらかに揃えて下さい(現在のコードでは、追加したIDは、文字列と成ります)

Option Explicit

'Listの列数
Const lngCoiumns As Long = 7

'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()

'  行の削除

  '現在行が未定なら
  If lngCurrent = 0 Then
    Exit Sub
  Else
    If MsgBox(TextBox1.Text & "のデータが削除されます", _
        vbExclamation + vbOKCancel, "行削除") = vbOK Then
      '行を削除
      rngList.Offset(lngCurrent).EntireRow.Delete
    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 lngCoiumns
      Controls("TextBox" & i).Text = .Offset(lngRow, i - 1)
    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 lngCoiumns
      .Offset(lngRow, i - 1) = 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 lngCoiumns
    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

【24405】登録方法 まこと 05/4/21(木) 17:32 質問
【24407】Re:登録方法 ni 05/4/21(木) 17:49 発言
【24421】Re:登録方法 YN61 05/4/21(木) 21:34 回答
【24491】Re:登録方法 Hirofumi 05/4/23(土) 7:16 回答
【24496】Re:登録方法 まこと 05/4/23(土) 10:26 質問
【24497】Re:登録方法 Hirofumi 05/4/23(土) 11:41 回答
【24498】Re:登録方法 Hirofumi 05/4/23(土) 11:48 回答
【24506】Re:登録方法 まこと 05/4/23(土) 17:39 質問
【24508】Re:登録方法 Hirofumi 05/4/23(土) 19:04 回答
【24509】Re:登録方法 Hirofumi 05/4/23(土) 19:14 発言
【24511】Re:登録方法 まこと 05/4/23(土) 20:36 お礼
【24510】Re:登録方法 YN61 05/4/23(土) 20:03 発言
【24514】Re:登録方法 サラリーマン 05/4/23(土) 22:27 発言
【24515】Re:登録方法 サラリーマン 05/4/23(土) 22:29 質問
【24517】Re:登録方法 Hirofumi 05/4/23(土) 23:15 回答
【24523】サラリーマンさんの質問について Hirofumi 05/4/24(日) 7:05 発言
【24524】Re:サラリーマンさんの質問について サラリーマン 05/4/24(日) 8:02 発言

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