VBA 行を絞り込み、列を検索をして転記するコードについて教えて下さい。

Question

前提・実現したいこと

EXCEL　VBA　超初心者です。
SHEET1のD列の数値をSHEET2の行列が合致するセルに転記するエクセル表を作っています。
SHEET2の行は日付と時間、列は地点です。

オートフィルタで行を絞ろうと思ったのですが、行を指定するコードで躓いています。

エラーメッセージは以下です。
実行時エラー'1004'
'Range’メソッドは失敗しました。'Worksheetオブジェクト'

列の指定もこれでいいのか不安です。
ご指導のほど、よろしくお願いいたします。

該当のソースコード

Sub Tenki()
Const MOTO_KEY_ROW As Long = 1 '「Sheet1」シートのキー行（項目見出し行:1行目）
Const KENSAKU_ROW As Long = 1 '「Sheet2」1行目

Dim Sh_Moto As Worksheet    '「Sheet1」シート
Dim Sh_Tenki As Worksheet   '「Sheet2」シート

'Dictionaryオブジェクトの宣言
Dim dicKomoku As Object     'Sheet1の項目名列番号ディクショナリ

Dim iRRow As Integer        'Sheet1シートの読込行
Dim iRCol As Integer        'Sheet1シートの読込列
iRCol = 4

Dim iWRow As Integer        'Sheet2シートの出力行
Dim iWCol As Integer        'Sheet2シートの出力列

Set Sh_Moto = Worksheets("Sheet1")
Set Sh_Tenki = Worksheets("Sheet2")

Set dicKomoku = CreateObject("Scripting.Dictionary")

'【ディクショナリ作成】
'Sheet1シートから項目名のディクショナリを作成
For iRCol = 3 To Sh_Moto.Cells(MOTO_KEY_ROW, 3).End(xlToRight).Column
    '項目名をキーとして列番号をディクショナリに保管
    dicKomoku(Sh_Moto.Cells(1, iRCol).Value) = iRCol
Next iRCol

'【転記処理】
'Sheet2シートの社名ループ

Dim MaxRow As Long
MaxRow = Sh_Moto.Cells(Rows.Count, 1).End(xlUp).Row
For iRRow = 2 To MaxRow

'ws2の行をフィルタリング
Sh_Tenki.Select
Range("A1").Select

Selection.AutoFilter
Selection.Range("A1").AutoFilter Field:=1, Operator:=xlFilterValues, Criteria2:=Sh_Moto.Range(iRRow, 1).Value2  'ここでストップします。
Selection.Range("A1").AutoFilter Field:=2, Criteria1:=Sh_Moto.Range(iRRow, 2).Value

'フィルタされた行の行番号を取得
    iWRow = ActiveSheet.Row

        'Sheet2シートの項目ループ
        For iWCol = 4 To Sh_Moto.Cells(KENSAKU_ROW, 4).End(xlToRight).Column
            '項目名からSheet1の列番号を取得
            If dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value) = "" Then
                '項目名から列番号が取得できない場合は何もしない
            Else
                'Sheet1の列番号を取得
                iRCol = dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value)
                '「Sheet1」シートの取得行・取得列のセルの値を、「Sheet2」シートの出力行・出力列に出力する
                Sh_Tenki.Cells(iWRow, iWCol).Value = Sh_Moto.Cells(iRRow, iRCol).Value
            End If
        Next iWCol
Selection.Range("A1").AutoFilter
Next iRRow

End Sub

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

Answer 1

転記先の行番号、列番号の方を辞書にしたらどうでしょう。

Sub Sample()
    Dim Sh_Moto As Worksheet    '「Sheet1」シート
    Dim Sh_Tenki As Worksheet   '「Sheet2」シート
    Set Sh_Moto = Worksheets("Sheet1")
    Set Sh_Tenki = Worksheets("Sheet2")

    With Sh_Tenki
        Dim dicRow As Object
        Dim dicCol As Object     'Sheet2の項目名行番号ディクショナリ
        Set dicRow = CreateObject("Scripting.Dictionary")
        Set dicCol = CreateObject("Scripting.Dictionary")
        Dim c As Range
        For Each c In .UsedRange.Columns(1).Cells
            dicRow(c.Text & vbTab & c.Offset(, 1).Value) = c.Row
        Next
        For Each c In .UsedRange.Rows(1).Cells
            dicCol(c.Value) = c.Column
        Next
    End With

    With Sh_Moto
        Dim i
        For i = 2 To .UsedRange.Rows.Count
            Sh_Tenki.Cells(dicRow(.Cells(i, 1).Text & vbTab & .Cells(i, 2).Value), dicCol(.Cells(i, 3).Value)).Value = .Cells(i, 4).Value
        Next
    End With
End Sub

Comments

[chuzenji_c]

大変ありがとうございました。
実際使うものには列が900ほどあるのですが、頂いたコードをアレンジしてうまく動いたので、思わず拍手してしまいました。勤務先の情報担当にアドバイスを求めても門前払いでしたので、こちらで伺ってお返事いただいて、本当に助かりました。参考書にもＷＥＢにも載っていないこのようなコードが書けるように、自分も精進したいです。
teratailに出会えてよかったです。

Answer 2

コードの内容は精査してませんが、下記はあきらかな間違いです。

Sh_Moto.Range(iRRow, 1).Value2

正しくは、

Sh_Moto.Cells(iRRow, 1).Value2

Comments

[chuzenji_c]

ありがとうございました。