Excel VBA質問箱 IV

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

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


74908 / 76732 ←次へ | 前へ→

【6276】Re:検索画面
回答  Hirofumi E-MAIL  - 03/6/22(日) 11:10 -

引用なし
パスワード
   横から失礼します
取りあえず、社員コード及び、社員氏名から行を探索するUserFormを作成して見ました

条件として、
1、社員コードは昇順で並んでいる事(尚、社員コードは文字列で有る事を想定しています
 もし、数値の場合、Sub TextBox1_BeforeUpdateでコメントアウトして有る行を活かし
 上の行をコメントアウトして下さい)
2、社員コード及び、社員氏名の探索の成功時C列のセルがアクティブに成ります
3、社員コードはA列、社員氏名はB列に有り、共に列見出しが有るものとしています
 詰まり、社員コードはA2、社員氏名はB2から始まります
4、UserFormの対象シートはアクティブシートと成ります

UserFormの構成は、
 TextBox1 → 社員コード探索
 TextBox2 → 社員氏名探索
 TextBox3 → 入力データ
 CommandButton1 → セルに書き込み
 CommandButton2 → UserFormの終了
です

コードは、以下を標準モジュールへ転記して下さい

Public Sub 入力()

  UserForm1.Show
  
End Sub


以下をUserFormのコードモジュールに転記して下さい

'この行は設定によっては書きこまれて出てきます
Option Explicit

'UserForm内の範囲で参照出来る変数を宣言
Private rngCodeScope As Range
Private rngNameScope As Range
Private blnDirty As Boolean
Private lngWriteRow As Long

Private Sub CommandButton1_Click()

'  セルへの書き込み

  If lngWriteRow = 0 Then
    Exit Sub
  End If
  
  With Cells(lngWriteRow, 1)
    .Offset(, 5).Value = TextBox3.Text
  End With
    
End Sub

Private Sub CommandButton2_Click()

' UserFormの終了処理

  Unload Me
  
End Sub

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

'  社員コード探索の値が変更された場合(厳密に言うと違うのですが)

  Dim lngFind As Variant
  
  'もし、TextBox2の変更に伴う時
  If blnDirty Then
    'Subを抜ける
    blnDirty = False
    Exit Sub
  End If
  
  With TextBox1
    'もし、値が""で無いなら
    If .Value <> "" Then
      'TextBox2の値を""にする
      TextBox2.Text = ""
      'Match関数を用いて、社員コードの範囲から探す(完全一致)
      lngFind = RowSearch(CStr(.Text), rngCodeScope)
      'もし、社員コードが有った場合
      If lngFind <> 0 Then
        With Cells(lngFind, 1)
          'その行のC列をActiveにする
          .Offset(, 2).Activate
          '変更フラグをTrueにする
          blnDirty = True
          'TextBox2の値にその行の氏名を代入
          TextBox2.Text = .Offset(, 1).Value
        End With
        '書き込み行位置を探索位置に更新
        lngWriteRow = lngFind
        'TextBox3にフォーカスを移動
        TextBox3.SetFocus
      Else
        'コントロールの移動をキャンセル
        Cancel = True
        '書き込み行位置を0に(探索失敗)
        lngWriteRow = 0
        Beep
        MsgBox .Text & "の社員番号は有りません"
      End If
    End If
  End With
  
End Sub

Private Sub TextBox2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

'  社員氏名探索の値が変更された場合(厳密に言うと違うのですが)

  Dim rngFind As Range
  
  'もし、TextBox1の変更に伴う時
  If blnDirty Then
    blnDirty = False
    Exit Sub
  End If
  
  With TextBox2
    'もし、TextBox2値が""で無いなら
    If .Text <> "" Then
      'TextBox1の値を""に
      TextBox1.Text = ""
      'Findを用いた探索(部分一致)で社員氏名の範囲から探す
      Set rngFind = rngNameScope.Find(What:=TextBox2.Text, _
                      LookIn:=xlFormulas, _
                      LookAt:=xlPart, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False)
      'もし探索が成功したなら
      If Not rngFind Is Nothing Then
        With rngFind(, 1)
          '探索位置をActiveに
          .Offset(, 1).Activate
          '社員氏名に氏名を代入
          TextBox2.Text = .Offset().Value
          '変更フラグをTrueにする
          blnDirty = True
          'TextBox1の社員コードを代入
          TextBox1.Text = .Offset(, -1)
        End With
        '書き込み行位置を探索位置に更新
        lngWriteRow = rngFind.Row
        TextBox3.SetFocus
      Else
        Cancel = True
        lngWriteRow = 0
        Beep
        MsgBox .Text & "の社員名は有りません"
      End If
      Set rngFind = Nothing
    End If
  End With
  
End Sub

Private Sub UserForm_Initialize()

'  UserFormの初期設定

  '社員コード範囲を取得
  Set rngCodeScope = Range(Cells(2, 1), _
                Cells(65536, 1).End(xlUp))
  '社員氏名範囲の取得
  Set rngNameScope = Range(Cells(2, 2), _
                Cells(65536, 2).End(xlUp))
    
End Sub

Private Sub UserForm_Terminate()

  Set rngCodeScope = Nothing
  Set rngNameScope = Nothing
  
End Sub

Private Function RowSearch(vntKey As Variant, _
              rngScope As Range) As Long

  Dim vntFind As Variant
  Dim lngDataTop As Long
  
  '範囲先頭行位置
  lngDataTop = rngScope.Row
  'Matchによる探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind, 1).Value Then
      '戻り値として、行位置を代入
      '(探索失敗の場合戻り値0を返す)
      RowSearch = vntFind + lngDataTop - 1
    End If
  End If
  
End Function

作成方法
1、「ツール」→「マクロ」→「Bisual Vasic Editor」を選択しVBEを起動
2、「挿入」→「標準モジュール」で標準モジュールをプロジェクトに追加
3、標準モジュールに転記するコードをコピペ
4、「挿入」→「ユーザーフォーム」でUseFormをプロジェクトに追加
5、ツールボックスからTextBoxを3つ、コマンドボタンを2つドラッグアンドドロップ
6、「表示」→「コード」でUserFormのコードモジュールを表示
7、UserFormのコードモジュールに転記するコードをコピペ
8、「デバッグ」→「VBAProjectのコンパイル」でコンパイルする
以上
0 hits

【6261】検索画面 ももこ 03/6/21(土) 11:49 発言
【6262】Re:検索画面 ももこ 03/6/21(土) 11:50 質問
【6266】説明不足ですいません。 ももこ 03/6/21(土) 22:45 質問
【6263】Re:検索画面 Hirofumi 03/6/21(土) 15:18 発言
【6264】フォームの自作 Be Quit 03/6/21(土) 16:18 回答
【6267】詳細なシート Be Quit 03/6/22(日) 0:35 質問
【6269】Re:詳細なシート ももこ 03/6/22(日) 9:18 質問
【6270】より詳細に、 Be Quit 03/6/22(日) 9:51 回答
【6271】Re:より詳細に、 ももこ 03/6/22(日) 10:13 質問
【6272】VBEditorをひらいて・・・ Be Quit 03/6/22(日) 10:28 回答
【6274】Re:VBEditorをひらいて・・・ ももこ 03/6/22(日) 10:43 質問
【6275】Re:VBEditorをひらいて・・・ ももこ 03/6/22(日) 10:48 質問
【6277】コピペ Be Quit 03/6/22(日) 11:12 回答
【6278】Re:コピペ ももこ 03/6/22(日) 11:30 質問
【6283】Re:コピペ Be Quit 03/6/22(日) 12:06 回答
【6285】できたかな? Be Quit 03/6/22(日) 13:14 回答
【6286】Re:できたかな? ももこ 03/6/22(日) 13:45 質問
【6288】Re:できたかな? Be Quit 03/6/22(日) 13:54 回答
【6289】Re:できたかな? ももこ 03/6/22(日) 13:58 質問
【6290】確認します Be Quit 03/6/22(日) 14:15 回答
【6291】Re:確認します ももこ 03/6/22(日) 14:31 質問
【6293】贅沢だ Be Quit 03/6/22(日) 15:07 回答
【6294】Re:贅沢だ ももこ 03/6/22(日) 15:14 お礼
【6296】そりゃよっかったね Be Quit 03/6/22(日) 15:30 回答
【6297】Re:そりゃよっかったね ももこ 03/6/22(日) 15:55 お礼
【6299】がんばりや。 Be Quit 03/6/22(日) 17:11 回答
【6276】Re:検索画面 Hirofumi 03/6/22(日) 11:10 回答
【6279】Re:検索画面 Hirofumi 03/6/22(日) 11:34 回答
【6280】Re:検索画面 ももこ 03/6/22(日) 11:38 質問
【6281】Re:検索画面 Hirofumi 03/6/22(日) 11:46 発言
【6284】Re:検索画面 ももこ 03/6/22(日) 12:09 お礼
【6295】Re:検索画面 Hirofumi 03/6/22(日) 15:30 発言

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