こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

【VBA】Ifで他シートから検索しコピーする

Excel vbaについて教えてください。
自分で作成したコードが、うまく動かず悩んでいます。

●作りたいもの
Sheet3のA列にある数字を検索値とし、
Sheet1のA列を検索し、合致する行のB列~最終列までコピーし、
Sheet3のB列から貼付する。
※Sheet1にある列数(項目数)は不定です

●作成したマクロ
Sub test()
Dim sh1 As WorkSheet
Dim sh2 As WorkSheet

Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")

d = sh2.Range("A1").End(xlDown).Row 'Sheet3検索値のA列のデータの最終行
g = sh1.Range("B1").End(xlToRight).Column 'Sheet1の最終列
k = 2
For i = 2 To d    'Sheet3最終行まで
If sh1.Cells( i & "A") = sh2.Cells( 1,"A") Then '条件)Sheet1とSheet3のA列が合致
For j = 2 To g                      'Sheet1の最終列まで
sh2.Cells( k , j ) = sh1.Cells( i , j ) 'Sheet1のB行から最終列をコピーしSheet3へ貼付

Next j
End If
Next
End Sub


いろいろ直していたのですが、Set sh2 = Worksheets("Sheet3")で「インデックスが有効範囲にありません」(同じブック内に同名シートがあるのに?)とエラーが出たり、
また、B行から最終列までコピーする際の範囲指定についてもよくわからず、
もっと他に良い方法が無いものかとお手上げ状態です。

どうぞ宜しくお願いいたします。

投稿日時 - 2013-02-22 20:56:45

QNo.7959120

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

下記のような事で良いでしょうか。
1.シート3のセルA1データでシート1のA2以降最終行までの検索を行い。
2.シート1の検索した行のB列から最終列のデータをシート3のB2の行にデータ入力

シート1のデータの列数が全て同数なのか不明なので、最大列数の検索は、データ検索後にする事にしています。
検索結果が一致しない場合はエラーメッセージを表示します。
意図する物違う場合は、手直し下さい。

Sub test()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim d, i, j, k As Integer

Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
g = 0
d = sh1.Range("A1").End(xlDown).Row
k = 2

For i = 2 To d

'シート3のセルA1の値とシート1、A列の値が同一行を検索
If sh1.Cells(i, 1) = sh2.Cells(1, 1) Then
g = sh1.Range("B" & i).End(xlToRight).Column

For j = 2 To g
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j

Exit For

End If

Next

If g = 0 Then MsgBox "一致するデータは有りませんでした。シート3のA1データを確認して下さい。"

End Sub

投稿日時 - 2013-02-23 00:07:28

補足

ご回答いただき、ありがとうございます。
いただいた回答を試す環境が会社にしかなく、返答が遅くなってしまい申し訳ありませんでした。

補足ですが、
>シート1のデータの列数が全て同数なのか不明なので
シート1のデータ列数はすべて同数です。

早速試しましたところ、
シート3のA列の検索値に一致するものが、シート1の検索範囲にあるにも関わらず「一致するデータなし」とメッセージが出た為、以下を修正しました。
If sh1.Cells(i, 1) = sh2.Cells(1, 1) Then
→ If sh1.Cells(1, i) = sh2.Cells(1, i) Then

その結果、添付いただいた画像通りになりましたが、
シート3のA列1行目で検索が終わってしまうようでした。

検索値が複数ある場合を想定して、
シート3のA列にある検索値をA1から下まで行うにはどうすればよいでしょうか?

別案として、
g = sh2.Range("B1").End(xlToRight).Column
r = 1
Do While sh2.Range("A" & r ).Value<>""
Set f = sh2.Columns("A").Find sh2.Range("A"& r ).Value, LookAt:=xlWhole, LookIn:=xlValues
If Not f Is Nothing Then
Sheet3.Cells( g , r).Value = Sheet1.Cells( g , f).Value
End If
r = r + 1
Loop

というのも考えたのですが、
Sheet3.Cells( g , r).Value = Sheet1.Cells( g , f).Value
セル設定が間違えているようで、ここでRangeオブジェクト?のエラーが出てしまいます。


もしよろしければ修正点を教えていただけないでしょうか。

投稿日時 - 2013-02-25 20:55:58