| |
はじめまして こんにちは
マクロを勉強してまだ１月ちょっとのですが、必要に迫られ必死に
組んでいます いつも参考にさせていただいており皆さんとても
親切に教えてくれていてすごく感動しています。
投稿に当たっては、過去ログや検索を使って調べてみましたが
探し方が悪いのか見つかりませんでしたので投稿してみました
過去にあったらごめんなさい とりあえず見ていただけると幸いです。
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の部分をどう替えるといいのかが解りません
いままでは１つの検索条件でしかやった事が無く困っています
（最初は条件をひとつずつけんさくしてました）
どなたかお分かりになる方がいらっしゃいましたらヒントをお願いいたします
|
|
勉強中です
- 06/6/21(水) 9:30 -
