Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7421 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【39279】別シートの複数の値での検索 勉強中です 06/6/21(水) 9:30 質問[未読]
【39280】Re:別シートの複数の値での検索 Statis 06/6/21(水) 9:51 回答[未読]
【39281】Re:別シートの複数の値での検索 Jaka 06/6/21(水) 10:24 回答[未読]
【39284】Re:別シートの複数の値での検索 勉強中です 06/6/21(水) 12:25 お礼[未読]
【39279】別シートの複数の値での検索
質問  勉強中です E-MAIL  - 06/6/21(水) 9:30 -
引用なし
パスワード
   はじめまして　こんにちは
マクロを勉強してまだ１月ちょっとのですが、必要に迫られ必死に
組んでいます　いつも参考にさせていただいており皆さんとても
親切に教えてくれていてすごく感動しています。
投稿に当たっては、過去ログや検索を使って調べてみましたが
探し方が悪いのか見つかりませんでしたので投稿してみました

過去にあったらごめんなさい　とりあえず見ていただけると幸いです。


Sheet1
　　　　A　　　　　　Ｂ　　　　　　　Ｃ　　・・・・・　　Ｉ
1　取引先コード　　商品コード　　　商品名
2　100100　　　 （ＪＡＮコード）　　いす　
3　112356　　　　　　　　　　　　　　棚　
4　134672　　　　　　　　　　　　　　箪笥
sheet1のA列は重複している数字がありますＢ列はありません

sheet2
１行目のみsheet1と同じ内容２行以下は空白です　　　

sheet3
　　　 A
1　　100100
2　　100101
3　　　・
4　　　・
　　中略
500　567432
Sheet3はＡ列以外の入力はありません

このsheet3のＡ列の数字を使用してsheet1のＡ列を検索して
同じコードがあればsheet2の２行目以下にその行をコピーする
というマクロを組んでいます。


Sub 対象検索()


Dim Sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim lngS1RowIdx As Long　 'シート1の行インデック
Dim lngS2RowIdX As Long　 'シート2の行インデック
Dim lngS3RowIdX As Long　 'シート3の行インデック
Dim lngS2StartRow As Long　'シート2の貼り付け開始行
Dim lngMaxRow As Long '最大行数
Dim lngCopyCell As Long 'コピーするセル数
Dim lngCellIdx As Long 'コピーするセルのインデック

lngS2StartRow = 2
lngMaxRow = 10000
lngCopyCell = 9

Set Sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
Set sh3 = Worksheets("sheet3")
On Error GoTo ELine
　
　lngS2RowIdX = lngS2StartRow
　For lngS1RowIdx = 2 To lngMaxRow
　　If Sh1.Cells(lngS1RowIdx, 1).Value = "" Then　'空白が入っていたらループを抜ける(外側のループ)
　　　Exit For
　　End If
　　For lngS3RowIdX = 1 To lngMaxRow
　　　If sh3.Cells(lngS3RowIdX, 1).Value = "" Then '空白が入っていたらループを抜ける(内側のループ)
　　　　Exit For
　　　End If
　　　If Sh1.Cells(lngS1RowIdx, 1).Value = sh3.Cells(lngS3RowIdX, 1).Value Then
　　　　For lngCellIdx = 1 To lngCopyCell
　　　　　sh2.Cells(lngS1RowIdx, lngCellIdx).Value = Sh1.Cells(lngS2RowIdX, lngCellIdx).Value
　　　　Next
　　　　lngS2StartRow = lngS2StartRow + 1
　　　End If
　　Next lngS3RowIdX
　Next lngS1RowIdx
　MsgBox "終了"
　

ELine:
Set Sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing


End Sub

上記のように作りましたが　複数ある条件でしかもhitしたもの
全部をコピーするには、ifの部分をどう替えるといいのかが解りません
いままでは１つの検索条件でしかやった事が無く困っています
（最初は条件をひとつずつけんさくしてました）
どなたかお分かりになる方がいらっしゃいましたらヒントをお願いいたします
【39280】Re:別シートの複数の値での検索
回答  Statis  - 06/6/21(水) 9:51 -
引用なし
パスワード
   こんにちは

検索で組んでみました。お試しを。

Sub Test_Copy()
Dim R As Range, C As Range, Ws As Worksheet
Dim Fi As Range, Ad As String

Set Ws = Worksheets("Sheet2")
With Worksheets("Sheet3")
　　 Set R = .Range("A1", .Range("A65536").End(xlUp))
End With
With Worksheets("Sheet1")
　　 For Each C In R
　　　　 Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole, xlPrevious)
　　　　 If Not Fi Is Nothing Then
　　　　　　Ad = Fi.Address
　　　　　　Do
　　　　　　　Set Fi = .Columns(1).FindNext(Fi)
　　　　　　　Ws.Range("A65536").End(xlUp) _
　　　　　　　　.Offset(1).Resize(, 9).Value = Fi.Resize(, 9).Value
　　　　　　Loop Until Ad = Fi.Address
　　　　 End If
　　 Next C
End With
Set R = Nothing: Set Ws = Nothing
End Sub
【39281】Re:別シートの複数の値での検索
回答  Jaka  - 06/6/21(水) 10:24 -
引用なし
パスワード
   オートフィルタを使ってみました。
セルに関数が使われているようなら、計算方法を手動にしてください。

Dim SachRag As Range, FilTRg As Range, Cel As Range, Chek As Variant
With Sheets("Sheet3")
　　Set SachRag = .Range(.Range("A1"), .Range("A65536").End(xlUp))
End With
With Sheets("Sheet1")
　　Set FilTRg = .Range(.Range("A1"), .Range("A65536").End(xlUp))
End With
Application.ScreenUpdating = False
For Each Cel In SachRag
　　Chek = Application.Match(Cel.Value, FilTRg, 0)
　　If Not IsError(Chek) Then
　　　 FilTRg.AutoFilter Field:=1, Criteria1:=Cel.Value
　　　 FilTRg.Offset(1).Resize(FilTRg.Count - 1).SpecialCells(xlCellTypeVisible).Copy
　　　 Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1).PasteSpecial (xlPasteValues)
　　　 Sheets("Sheet1").ShowAllData
　　　 DoEvents
　　End If
Next
Sheets("Sheet1").AutoFilterMode = False
Application.ScreenUpdating = True
【39284】Re:別シートの複数の値での検索
お礼  勉強中です E-MAIL  - 06/6/21(水) 12:25 -
引用なし
パスワード
   　Statisさん　Jakaさん
ありがとう御座います。どちらもばっちりです。
ほんとに勉強不足で反省してます。
これからもよろしくお願いします。
返事の仕方がよくわからなくて別のレスを作ってしまいました
管理人様　利用されている皆様　申し訳ありませんでした。以後気をつけます。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7421 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free