| |
横から失礼します
取りあえず、社員コード及び、社員氏名から行を探索する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を３つ、コマンドボタンを２つドラッグアンドドロップ
6、「表示」→「コード」でUserFormのコードモジュールを表示
7、UserFormのコードモジュールに転記するコードをコピペ
8、「デバッグ」→「VBAProjectのコンパイル」でコンパイルする
以上
|
|
- 03/6/21(土) 15:18 -
