VBAコードが作動せず、どこに問題があるのか教えて下さい。

商品の受払を入力シートからA商品券受払帳に転記したいのですが、作動しません。なお、コードは次のとおりです。sheetの画面は添付のとおりです。入力シートから受払帳の黄色の部分以下行に「月、日に日付、摘要に「ｋ商店」、発行高の枚数」が最小限転記できるようにと設定したいと考えました。
試行錯誤しましたが、作動せず修正箇所がわかりません。教えて下さい。

Set sh10 = Worksheets("A商品券受払帳")
Set sh1 = Worksheets("入力シート")

If Not IsDate(Range("G5").Value) Then Exit Sub
Select Case Month(Range("G5").Value)

Case 4: mRow = 1
Case 5: mRow = 35

Case 6: mRow = 68
Case 7: mRow = 82
Case 8: mRow = 109
Case 9: mRow = 139
Case 10: mRow = 173
Case 11: mRow = 187
Case 12: mRow = 211
Case 1: mRow = 227
Case 2: mRow = 260
Case 3: mRow = 318
End Select
Call cashbook_main(mRow)
End Sub

Public Sub cashbook_main(mRow As Long)
Dim sh10 As Worksheet
Dim sh1 As Worksheet
Dim maxrow As Long
Dim Row As Long
Dim dicT As Object
Dim key As Variant
Set sh10 = Worksheets("A商品券受払帳")
Set sh1 = Worksheets("入力シート")
Set dicT = CreateObject("Scripting.Dictionary")
maxrow = sh1.Cells(Rows.Count, "H").End(xlUp).Row

For Row = 2 To maxrow
key = sh10.Cells(Row, "G").Value
dicT(key) = Row

Next
key = sh1.Cells(2, "Q").Value
If dicT.exists(key) = False Then
MsgBox ("伝票番号=" & key & "は商品券受払にありません")
Exit Sub
End If

If sh1.Cells(18, "M").Value = "" Then
sh1.Cells(Row, "G") = ""
MsgBox ("枚数が未表示です")
Exit Sub
End If

Row = dicT(key)
sh10.Cells(Row + mRow, "F").Value = sh1.Cells(7, "C").Value '名前
sh10.Cells(Row + mRow, "B").Value = sh1.Cells(5, "I").Value '年月日
sh10.Cells(Row + mRow, "G").Value = sh1.Cells(2, "Q").Value '伝票番号

MsgBox ("A商品券受払帳に転記します")

End Sub