【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行から最終列までコピーする際の範囲指定についてもよくわからず、
もっと他に良い方法が無いものかとお手上げ状態です。

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

回答No.1

noname#203218

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

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

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

'シート３のセルA1の値とシート１、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 "一致するデータは有りませんでした。シート３のA1データを確認して下さい。"

End Sub

補足

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

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

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

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

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

別案として、
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オブジェクト？のエラーが出てしまいます。

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