[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【VBA】別シートからXLOOKUPで最終行のセルまで対応したデータを取得』（トロ）
マクロのXLookupを使用し、sheets("1")のC3から最終行までに入力した値（入力と同時に）を、sheets("2")とsheets("3")のA2から最終行までの値が同じであった場合、sheets("1")のD3（C3から最終行までに入力した値の隣のセル）にsheets("2")とsheets("3")のA2から最終行までに同じ値だったセルの隣の文字を反映させたいと思っております。
以下のコードで作成したのですが、上手くいきませんでした。
問題点は以下の通りでした。
・sheets("1")C3に値を入力し、sheets("2")の文字を反映させたあと、C3の入力内容を消去した場合、D2まで消えてしまう。
・sheets("1")にsheets("3")に該当する値を入力すると、処理落ちしてしまう。
・sheets("1")にsheets("2")sheets("3")にない値を入れると処理落ちしてしまう。
XLookupだけでなく、何か良い解決方をご教示頂けないでしょうか。
よろしくお願いします。
Private Sub Worksheet_Change(ByVal Target As Range)
'プログラム2|バックグラウンドで作動
Application.ScreenUpdating = False
Dim r As Range
Dim r2 As Range
Dim r3 As Range
'シート番号を使う
With Sheets("1")
Set r = .Range("C3", .Cells(.Rows.Count, "C").End(xlUp))
End With
With Sheets("2")
Set r2 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With Sheets("3")
Set r3 = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
r.Offset(0, 1) = WorksheetFunction.XLookup(r, r2, r2.Offset(0, 1), "")
r.Offset(0, 1) = WorksheetFunction.XLookup(r, r3, r3.Offset(0, 1), "")
End Sub
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
説明が分かりにくいです。
A B C
1
2
3
4
のような行番号列番号がわかる形式で、サンプルケースを示して説明してください。
（お願い） 2022/10/06(木) 15:50
Private Sub Worksheet_Change Application.EnableEvents = False で検索
（マナ） 2022/10/06(木) 16:07
If Intersect(target, Columns("C")) Is Nothing Then Exit Sub
これも、あったほうがよいです。
（マナ） 2022/10/06(木) 16:13
3 2022-10-1 A001 001 イチゴ ←・C3を入力すると、sheets("2")または
sheets("3")の商品名がD3に自動で反映
4 されるが、C3を消すとD2（名）まで消える。
以下最終行まで続く（行数は変化する） ・C3にsheets("3")のコードを入力すると、
処理落ちする。
sheets("2") ・C3にsheets("2")またはsheets("3")にない
A B C コードを入力すると、処理落ちする。
1 コード 商品名 値段
2 001 イチゴ 100
3 002 リンゴ 200
4 003 バナナ 300
以下最終行まで続く（行数は変化する）
sheets("3")
A B C
1 コード 商品名 値段
2 101 トマト 100
3 102 ナス 200
4 103 レタス 300
以下最終行まで続く（行数は変化する）
（トロ） 2022/10/06(木) 16:24
これを"1"シートのシートモジュールに記入
Private Sub Worksheet_Change(ByVal Target As Range)
'セル１つ、列がＣ列、行が３行目以降なら
If Target.Count = 1 And Target.Column = 3 And Target.Row >= 3 Then
Application.EnableEvents = False 'イベント抑止
Sample Target '抽出を実施
Application.EnableEvents = True 'イベント抑止解除
End If
End Sub
これを標準モジュールに記入
Sub Sample(rng As Range)
Dim ws As Worksheet
Dim shname, r
Dim oRow As Long
For Each shname In Array("2", "3") 'シート"2"とシート"3"を巡回
Set ws = Worksheets(shname) 'ワークシートを変数に入れる
For Each r In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)) 'A2〜A列最終行まで巡回
If r.Value = rng.Value Then 'セルの値と引数セルの値が同じなら
If oRow > 0 Then '2箇所目以降の場合
rng.Offset(oRow).Resize(, 2).Insert shift:=xlDown '引数セルとその右隣のセルにセルを挿入（下に移動）
End If
rng.Offset(oRow, 1).Value = r.Offset(0, 1).Value 'B列の値を引数セルの右側（2か所目以降は下にシフト）に入力
oRow = oRow + 1 'カウンタ（オフセット数）加算
End If
Next
Next
End Sub
（下手の横好き） 2022/10/06(木) 16:47
=IFERROR(IFERROR(VLOOKUP(C3,'2'!$A:$B,2,false),VLOOKUP(C3,'3'!$A:$B,2,false)),"")
もしかしてこれでよかったのでしょうか
（下手の横好き） 2022/10/06(木) 16:51
Sub Sample(rng As Range)
Dim ws As Worksheet
Dim shname, r
Dim oRow As Long
For Each shname In Array("2", "3") 'シート"2"とシート"3"を巡回
Set ws = Worksheets(shname) 'ワークシートを変数に入れる
'A2〜A列最終行までに引数セルの値と一致するものを探す
oRow = Application.Match(rng.Value, ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)), 0)
If IsNumeric(oRow) Then '一致したものがあったら
oRow = oRow + 1 '見出し行の値を加算してセルの行数に合わせる
rng.Offset(0, 1).Value = ws.Cells(oRow, "B").Value '引数セルの右隣セルにB列の値を入力
Exit For 'シート巡回を脱出
End If
Next
End Sub
一致したものが一つあった時点でそれを転記して終了の場合のものに書き換えてみました。
（下手の横好き） 2022/10/06(木) 17:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.