Excel VBA ：2回目以降実行で貼り付けるセルが変わる

いつもお世話になっております。

ExcelのVBAでご質問があります。
指定した日付のデータを抽出して
別のシートに貼り付けるサブプロシージャなのですが、
下記のようなコードを書きましたところ、
貼り付けるセルが何故か("BH2")になってしまいます。

コードの一部を変えて、実行するとコード通り
("BH3")のセルに貼り付けてくれるのですが、
もう一度別の日付を入力して実行すると
("BH2")のセルに貼り付けてしまうのです。

何が原因なのでしょうか・・・？
ちなみに最初にコードを書いたときは
貼り付け先は("BH2")のセルにしていましたが
途中で間違いに気づき、("BH3")に書き換えました。
これが関係あるのでしょうか。

何卒よろしくお願いします。
------------------------------------------------------
Sub 予定表()
Application.ScreenUpdating = False
'ファイルオープン
Dim i As Integer
For i = 1 To Workbooks.Count
If (Workbooks(i).Name = "予定表.xls") Then
Exit For
End If
Next
If (i > Workbooks.Count) Then Workbooks.Open Filename:="\\Dress\予定表.xls"
' 予定表の取り込み
Dim date1 As Date
Dim fmt As String
Dim objList1 As ListObject
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Rng As Range
Dim sh1 As Worksheet
Dim sh4 As Worksheet
'-----------------------------------------------------------------------
Set wb1 = Workbooks("製品.xls")
Set wb2 = Workbooks("予定表.xls")
Set sh1 = wb1.Worksheets("Sheet1 (3)")
Set sh4 = wb2.Worksheets("1")
'-------------------------------------------------------------------------
sh1.Range("BH3:BN20").ClearContents
'日付のチェック
Do
date1 = Application.InputBox("日を入力して下さい。", "印刷日入力", Type:=2)
If VarType(date1) = vbBoolean Then Exit Sub
If IsDate(date1) = False Then MsgBox date1 & "　は、日付ではありません。"
Loop Until IsDate(date1)

With sh4
Set objList1 = .ListObjects("予定")
fmt = .Range("A2").NumberFormatLocal '書式を取る
date1 = Format(date1, fmt) '入力文字の書式変更

objList1.Range.AutoFilter Field:=1, Criteria1:=date1
Set Rng = objList1.Range.SpecialCells(xlCellTypeVisible)
Rng.Copy sh1.Range("BH3")
objList1.Range.AutoFilter Field:=1
End With
Application.CutCopyMode = False
Range("R3").Value = date1

Set Rng = Nothing
Set objList1 = Nothing
Set wb1 = Nothing
Set wb2 = Nothing
Set sh1 = Nothing
Set sh4 = Nothing
End Sub

No.1 ベストアンサー 回答者： Wendy02 回答日時： 2010/02/02 12:19

こんにちは。

半分以上は、たぶん私のコードのようですね。

このコードを何度も読みなおしましたが、このコードからは、ずれてしまう部分は考えられません。
このレベルは、もうデバッギングのテクニックで、自力で解決するしかありませんね。

もしかして、Call で呼び出していませんか？
コードが二重になっていないでしょうか？

必ず、そこを通っているか、

objList1.Range.AutoFilter Field:=1, Criteria1:=date1
　または、
Rng.Copy sh1.Range("BH3")

左の枠の部分をクリックして、●のブレークポイントをつけてみたらどうでしょうか？

コードと画面を見比べながら、どのような反応をしているか探さなくてはならないと思います。

私は、左側にExcelのワークシートを出しておいて、右側にVBEditor を出して、両方の様子を見ながら、ステップモード(F8) で進めて、原因を探します。ExcelのVesion によっては上手くいかないものもあるかもしれませんし、右・左はどちらでもよいことですが……。

この回答への補足

ご連絡遅くなりまして、申し訳ありません。
もう一度最初から作り直したらうまく行きました。
直接的な原因は不明ですが。。。
この度はありがとうございました。

補足日時：2010/02/09 08:59

この回答へのお礼

あ、どうも。いつもお世話になります！

お陰様でコードはかなり流用させて頂いてます。
新しく書く場合も大体同じルールでやってますし、
ほんとに助かってます。

＞もしかして、Call で呼び出していませんか？
＞コードが二重になっていないでしょうか？
という所がちょっと意味が分からないのですが、
よく思い出してみると、いつもと違う手順で
作り始めた気がしてきました。

ちょっと検証してきます。

お礼日時：2010/02/03 17:24