Excel VBA質問箱 IV

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

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


39196 / 76732 ←次へ | 前へ→

【42651】Re:Noを手がかりにユーザフォームに表示させたい
回答  Hirofumi  - 06/9/17(日) 21:00 -

引用なし
パスワード
   >選択という意味が善く解らないのですが?
レコードの上下移動と言う意味でしょうか?
レコードの項目は違いますが、過去に作ったUserFormのコードが有りますので、
参考に成るかどうか見て下さい

尚、Noは昇順に並んでいることが条件です
探索の開始は、TextBox1のExitイベントで番号を探します
また、TextBox1に無い番号を入れた場合、新規入力に成り
例えば、10番、12番が存在する時、11番を指定すると10番、12番の間に行が挿入され11番が書きこまれます

UserFormの配置は、
TextBox1〜4
CommandButton1 入力(UserFormからセルに書き込み)
CommandButton2 削除(現在表示されている番号の行を削除)
CommandButton3 ↑移動
CommandButton4 ↓移動
を想定しています

以下のコードをUserFormモジュールに記入

Option Explicit

'Listの列数
Private Const clngColumns As Long = 7
'探索Keyの有る列位置(基準位置からの列Offset)
Private Const clngKeys As Long = 0

'Listの先頭、最左の列見出しのセル位置
Private rngList As Range
'Listの行数
Private lngRows As Long
'操作対象行位置
Private lngCurrent As Long
'存在Flag(0以外は、該当Keyが存在する)
Private lngFound As Long

Private Sub UserForm_Initialize()
  
  'Listの先頭セル位置を基準として設定(最左の列見出しのセル位置)
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'Listのデータ行数取得
    lngRows = .Offset(Rows.Count - .Row, clngKeys).End(xlUp).Row - .Row
    If lngRows < 0 Then
      lngRows = 0
    End If
  End With
    
  'スクロールバーの初期化
  With ScrollBar1
    .Max = lngRows
    .Min = 1
    .TabStop = False
    .LargeChange = 10
  End With
  
End Sub

Private Sub UserForm_Activate()

  'コントロールの初期化
  ControlsInitialize
  'データ範囲にデータが有るなら
  If lngRows > 0 Then
    '操作行を先頭行に
    lngCurrent = 1
    '存在行を先頭行に
    lngFound = 1
    'スクロールバーを先頭行に設定
    ScrollBar1.Value = lngCurrent
    RowUpDown
  Else
    '操作行を未定に
    lngCurrent = 0
    '存在行を未定に
    lngFound = 0
  End If
  
End Sub

Private Sub UserForm_Terminate()

  Set rngList = Nothing
  
End Sub

Private Sub CommandButton1_Click()
  
'  データを転記

  Dim i As Long

  '操作行が未定なら
  If lngCurrent = 0 Then
    Exit Sub
  End If
  
  '探索Keyが存在するなら
  If lngFound > 0 Then
    'データの上書き
    SetData lngCurrent
  Else
    '作成行がデータ範囲内なら
    If lngCurrent <= lngRows Then
      rngList.Offset(lngCurrent).EntireRow.Insert
    End If
    'List行数をインクリメント
    lngRows = lngRows + 1
    'スクロールバーの範囲を更新
    ScrollBar1.Max = lngRows
    '挿入位置にデータの転記
    SetData lngCurrent
  End If
  
  '存在行を操作行に
  lngFound = lngCurrent

End Sub

Private Sub CommandButton2_Click()

' 該当行を削除

  Dim i As Long
  
  If lngFound > 0 And lngCurrent > 0 Then
    Beep
    If MsgBox("Key " & TextBox1.Text & " のDataを削除します", _
        vbExclamation + vbOKCancel, "削除") = vbOK Then
      '操作行を削除
      rngList.Offset(lngCurrent).EntireRow.Delete
      'List行数をディクリメント
      lngRows = lngRows - 1
      'スクロールバーの範囲を更新
      ScrollBar1.Max = lngRows
      'データ行が有るなら
      If lngRows > 0 Then
        '次のデータを表示
        RowUpDown
        '存在行を操作行に
        lngFound = lngCurrent
      Else
        '操作行を未定に
        lngCurrent = 0
        '存在行を未定に
        lngFound = 0
        'コントロールの初期化
        ControlsInitialize
      End If
    End If
  End If
    
End Sub

Private Sub CommandButton3_Click()

'  行のDouwn

  lngCurrent = lngCurrent - 1
  RowUpDown
  
End Sub

Private Sub CommandButton4_Click()

'  行のUp

  lngCurrent = lngCurrent + 1
  RowUpDown
  
End Sub

Private Sub OptionButton1_Click()

  With OptionButton1
    .Parent.Tag = .Caption
  End With
    
End Sub

Private Sub OptionButton2_Click()

  With OptionButton2
    .Parent.Tag = .Caption
  End With
    
End Sub

Private Sub ScrollBar1_Change()

  lngCurrent = ScrollBar1.Value
  RowUpDown
  
End Sub

Private Sub TextBox1_Enter()

  'コントロールの初期化
  ControlsInitialize
  
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  Dim lngOver As Long
  Dim vntKey As Variant
  
  With TextBox1
    If .Text <> "" Then
      '探索Keyを取得
      vntKey = .Text
      'Listにデータ行が有るなら
      If lngRows > 0 Then
        'Listから該当するKeyの行を探索(探索Keyが数値の場合)
        lngFound = RowSearch(CLng(vntKey), rngList.Offset(1, _
                  clngKeys).Resize(lngRows), lngOver)
        'Listから該当するKeyの行を探索(探索Keyが文字列の場合)
'        lngFound = RowSearch(vntKey, rngList.Offset(1, _
                  clngKeys).Resize(lngRows), lngOver)
      Else
        lngFound = 0
        lngOver = 1
      End If
      '探索Keyの該当行が有る場合
      If lngFound > 0 Then
        '操作行を存在行に
        lngCurrent = lngFound
        'コントロールに値読み込み
        GetData lngCurrent
      Else
        'コントロールの初期化
        ControlsInitialize
        TextBox1.Text = vntKey
        Beep
        If MsgBox("該当するレコードが有りませんので新規作成します", _
            vbExclamation + vbOKCancel, "新規入力") = vbOK Then
          '操作行を行挿入位置に設定
          lngCurrent = lngOver
          CommandButton1.Enabled = True
        Else
          '操作行を未定に
          lngCurrent = 0
          Cancel = True
        End If
      End If
    Else
      '操作行を未定に
      lngCurrent = 0
      '存在行を未定に
      lngFound = 0
    End If
  End With

End Sub

Private Sub ControlsInitialize()

'  各コントロールの初期化

  Dim i As Long
  
  CommandButton1.Enabled = False
  CommandButton2.Enabled = False
  
  For i = 1 To 5
    Me.Controls("TextBox" & i).Text = ""
  Next i
  OptionButton1.Value = True
  TextBox6.Text = ""
  
End Sub

Private Sub GetData(lngRow As Long)

'  1行分のListデータを各コントロールに代入

  Dim i As Long
  Dim vntData As Variant
  
  With rngList.Offset(lngRow)
    .Activate
    'データを1行分、配列に取得
    vntData = .Resize(, clngColumns).Value
  End With
  
  '配列のデータを各コントロールに代入
  For i = 1 To 5
    Controls("TextBox" & i).Text = vntData(1, i)
  Next i
  With Frame1
    For i = 0 To .Controls.Count - 1
      If .Controls(i).Caption = CStr(vntData(1, 6)) Then
        .Controls(i).Value = True
        Exit For
      End If
    Next i
    If i > .Controls.Count - 1 Then
      .Controls(0).Value = True
    End If
  End With
  TextBox6.Text = Format(vntData(1, 7), "ggge年m月d日")
  
  CommandButton1.Enabled = True
  CommandButton2.Enabled = True
  
  'スクロールバーの表示位置更新
  With ScrollBar1
    If .Value <> lngRow Then
      .Value = lngRow
    End If
  End With
  
End Sub

Private Sub SetData(lngRow As Long)

'  各コントロールデータを1行分のListに代入

  Dim i As Long
  Dim vntData As Variant
  
  '1行分の出力用配列を確保
  ReDim vntData(1 To 1, 1 To clngColumns)
  
  '各コントロールの値を配列に代入
  For i = 1 To 5
    vntData(1, i) = Controls("TextBox" & i).Text
  Next i
  vntData(1, 6) = Frame1.Tag
  vntData(1, 7) = TextBox6.Text

  With rngList.Offset(lngRow)
    .Activate
    '配列を出力
    .Resize(, clngColumns).Value = vntData
  End With
  
  'スクロールバーの表示位置更新
  With ScrollBar1
    If .Value <> lngRow Then
      .Value = lngRow
    End If
  End With
  
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

Private Sub RowUpDown()

'  行のUP、Douwn

  'LIst範囲にデータが無い場合
  If lngRows < 1 Then
    lngCurrent = 0
    Exit Sub
  End If

  '操作行が、LIst範囲を超えるなら
  If lngCurrent > lngRows Then
    '操作行を最終行に
    lngCurrent = lngRows
  ElseIf lngCurrent < 1 Then
    '操作行を先頭行に
    lngCurrent = 1
  End If
  
  '存在行を操作行に
  lngFound = lngCurrent
  
  'コントロールに値読み込み
  GetData lngCurrent
  
  TextBox2.SetFocus
  
End Sub

尚、データは下記の物を想定しています
ID  氏名   郵便番号  住所            電話番号   性別  生年月日
1  山田 敬司 1120012  東京都文京区大塚X-XX-X    035978xxxx  男  昭和35年1月30日
2  木下 美絵 1790072  東京都練馬区光が丘X-X-X-XX  033976XXXX  女  昭和61年12月30日
4  篠ウ 望人 1920907  東京都八王子市長沼町XXX-XX  042636xxxx  男  昭和49年9月25日
0 hits

【42649】Noを手がかりにユーザフォームに表示させたい Tomi 06/9/17(日) 19:44 質問
【42650】Re:Noを手がかりにユーザフォームに表示... ponpon 06/9/17(日) 20:39 発言
【42651】Re:Noを手がかりにユーザフォームに表示さ... Hirofumi 06/9/17(日) 21:00 回答
【42653】Re:Noを手がかりにユーザフォームに表示さ... Hirofumi 06/9/18(月) 14:24 回答
【42655】Re:Noを手がかりにユーザフォームに表示さ... Tomi 06/9/18(月) 14:34 お礼
【42663】Re:Noを手がかりにユーザフォームに表示さ... Jigsaw 06/9/18(月) 19:43 回答
【42664】Re:Noを手がかりにユーザフォームに表示さ... Jigsaw 06/9/18(月) 19:47 回答
【42666】Re:Noを手がかりにユーザフォームに表示さ... Tomi 06/9/18(月) 20:55 お礼

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