VBA記述の仕方（2つの条件に合致したセルを別のシートへ転記）

Question

前提・実現したいこと

シート１
（転記元）
A B
1　日付 2021/10/2
2　家賃 80,000
3　光熱費 15,000
4　食費 58,000

という数値が入っています。
※こちらは、B１，B2，B3，B4に毎日、入力更新していきます。

シート２
（転記先）
A　　 B　　 C　　 D ・・・・
１　日付　2021/9/30 2021/10/1 2021/10/2 ・・・・
2 家賃 50,000 38,000 80,000　　・・・・
3　光熱費　10,000 12,000 15,000　　・・・・
4 食費　　80,000 73,000 58,000　　・・・・

転記先の日付は事前に入力しておりますが、
転記元の日付と転記先の日付が合致することで、
転記先の２，３，４行を転記したいです。

別シートにある条件に合致したセルに転記したい場合、
VBAの記述の仕方が知りたいと思っております。

※こちら、毎日更新し、
更新ボタンを転記元か転記先に作り、そのボタンを押すことで
自動更新するような形にできないかと考えております。
ボタンの作成の仕方やマクロの登録の仕方はわかります。

私が初めて、コードを書いており、多分、間違いが多いかと思います。
ご教授いただけますと幸いです。

Sub 登録()

Dim ThisSh As Worksheet
Dim ThisCh As Worksheet
Dim Clo As Long
Dim Rws As Long

Sh = Wb.Sheets("Sheet2")
Ch = Wb.Sheets("Sheet1")

Set ThisSh = ThisWorkbook.Sheets("Sheet1")
Set ThisCh = ThisWorkbook.Sheets("Sheet2")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A2")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B2")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A3")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B3")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A4")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B4")

Set ThisSh = Nothing
Set ThisCh = Nothing
Set Sh = Nothing
Set Ch = Nothing
Set Wb = Nothing

End Sub

よろしくお願い致します。

Comments

[hex309]

現時点で、プログラムはどこまでできていますか？
途中でもいいので、コードを提示されると回答が付きやすいと思います。

[sakura12]

こんにちは。
私が初めて、コードを書いており、多分、間違いが多いかと思います。
ご教授いただけますと幸いです。

Sub 登録()

Dim ThisSh As Worksheet
Dim ThisCh As Worksheet
Dim Clo As Long
Dim Rws As Long

Sh = Wb.Sheets("Sheet2")
Ch = Wb.Sheets("Sheet1")

Set ThisSh = ThisWorkbook.Sheets("Sheet1")
Set ThisCh = ThisWorkbook.Sheets("Sheet2")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A2")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B2")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A3")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B3")

col = ThisSh.Range("1:1").Find(What:=Ch.Range("B1")).Column
Rws = ThisSh.Range("A:A").Find(What:=Ch.Range("A4")).Row
ThisSh.Cells(Rws, col).Value = Ch.Range("B4")

Set ThisSh = Nothing
Set ThisCh = Nothing
Set Sh = Nothing
Set Ch = Nothing
Set Wb = Nothing

End Sub

[hex309]

ご提示ありがとうございます。
できれば、お手数ですが、質問が追記とうできるはずなので、そちらに記載してください。
ここだと、気づかない方のほうが多いと思いますので。

[sakura12]

かしこまりました。大変失礼いたしました。ありがとうございます。
追記致します。

Answer 1

余分な変数があるのと、元データとコピー先がごっちゃになってますね。
以下、ご参考まで
なお、対象の列を何度も検索する必要はないので、1回にしています。
まずは、以下を理解するようにしてみてください。

Sub 登録()
    Dim ThisSh As Worksheet
    Dim ThisCh As Worksheet
    Dim Col As Long
    Dim Rws As Long

    Set ThisSh = ThisWorkbook.Sheets("Sheet1")
    Set ThisCh = ThisWorkbook.Sheets("Sheet2")

    Col = ThisCh.Range("1:1").Find(What:=ThisSh.Range("B1").Value).Column
    
    Rws = ThisCh.Range("A:A").Find(What:=ThisCh.Range("A2").Value).Row
    ThisCh.Cells(Rws, Col).Value = ThisSh.Range("B2").Value

    Rws = ThisCh.Range("A:A").Find(What:=ThisCh.Range("A3").Value).Row
    ThisCh.Cells(Rws, Col).Value = ThisSh.Range("B3").Value

    Rws = ThisCh.Range("A:A").Find(What:=ThisCh.Range("A4").Value).Row
    ThisCh.Cells(Rws, Col).Value = ThisSh.Range("B4").Value

    Set ThisSh = Nothing
    Set ThisCh = Nothing
End Sub

Comments

[sakura12]

ありがとうございました！こちらで登録ができるようになりました！
本当に助かりました！

Answer 2

科目の順番が固定されているなら、一度にまとめてセットするのも手ですかね。

ThisCh.Range("1:1").Find(ThisSh.Range("B1").Value).Resize(4).Value = ThisSh.Range("B1:B4").Value

Comments

[sakura12]

ありがとうございます！私では考えつかないので、本当に素晴らしいと思いました！
また、よろしくお願い致します。