EXCEL VBA 転記 条件分岐 新規転記 上書転記 プログラム

いつも御世話になっております。
以下のことをしたいのですが、詰まってしまいました。
皆様の力をお借りしたいと思い、書き込ませていただきます。


・ボタン１をクリックすると、base（転記元）のG列に書かれた事項と同一のシート（転記先）へ転記する（各シートA,B,Cへ転記)
・転記先のE列を見て、既存のものであれば、上書きする
・転記先のＥ列を見て、新規のものであれば、空いている行を探し転記する。

(例)
base(転記元シート）
E1|F1|G1
名前収入シート先
月曜50A
火曜100A
木曜150C
土曜50A
日曜100B
水曜150A
金曜10C


転記実行前
A(転記先シート)
E1|F1|G1
名前収入シート先
月曜A
火曜A
土曜A



転記実行後
A(転記先シート)
E1|F1|G1
名前収入シート先
月曜50A
火曜100A
土曜50A
水曜150A

以下に作成したプログラムを記述します。
が、IF文に関するエラーが生じております。



Sub ボタン1_Click()

Dim dstSheet As Worksheet
Dim srcRow As Long
Dim dstRow As Long
Dim name As Integer
Dim obj As Object
Set srcSheet = Sheets("base")
For srcRow = 2 To srcSheet.Range("G" & Rows.Count).End(xlUp).Row '元シートのデータ範囲で繰り返し(シート先は必須なのでG列でチェック)

If srcSheet.Range("G" & srcRow).Value <> "" Then '(転記先シート名）が空白でない場合に実行(1)


Set dstSheet = Sheets(srcSheet.Range("G" & srcRow).Value) 'シート取得(1)
name = Sheets(srcSheet.Range("E" & srcRow).Value) '名前を取得(1)

Set obj = Worksheets(dstSheet).Cells.Find(name) '名前を転記先の中で検索(1)

End If '(1)の終了

If obj Is Nothing Then '検索でかからなかったら、新たに空白の行を見つけて転記元から転記先へ転記する(3)

'以下3行問題点????

dstRow = dstSheet.Range("G" & Rows.Count).End(xlUp).Row + 1 '転記先行取得
If dstSheet.Range("E2") = "" Then dstRow = 1 '質問で転記先には1行目からなので、それに対応
dstSheet.Range("E" & dstRow).Resize(1, 3).Value = srcSheet.Range("E" & srcRow).Resize(1, 3).Value 'データ転記

End If

Else '検索でかかったら、該当の行のアドレスを割り出し、特定の範囲を上書きする。(4)


lngYLine = obj.Row
intXLine = obj.Column

With Sheets(dstSheet) '検索でかかったら、該当の行のアドレスを割り出し、特定の範囲を上書きする。(4)


dstSheet.Range("E" & lngYLine).Resize(1, 3).Value = srcSheet.Range("E" & srcRow).Resize(1, 3).Value 'データ転記(4)

End If '(3),(4)の終了


Set obj = Nothing 'Objの初期化

Next

End Sub

No.4 ベストアンサー 回答者： onlyrom 回答日時： 2009/01/22 23:10

前回の続きみたいですね。

提示のコードはあちこちミスがあり(^^;;;
それらをいちいち文言で指摘するのがちょと面倒なので
訂正加筆したコードをアップします。
以下をコピペして実行してみてください。

'-----------------------------------------
Sub ボタン1_Click()

Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim srcRow As Long
Dim dstRow As Long

Dim name As String
Dim obj As Range

Set srcSheet = Sheets("Base")

For srcRow = 2 To srcSheet.Range("G" & Rows.Count).End(xlUp).Row
　If srcSheet.Range("G" & srcRow).Value <> "" Then
　　　Set dstSheet = Sheets(srcSheet.Range("G" & srcRow).Value)
　　　name = srcSheet.Range("E" & srcRow).Value
　　　Set obj = dstSheet.Range("E:E").Find(name, , xlValues, xlWhole)
　　　　　If obj Is Nothing Then
　　　　　　　dstRow = dstSheet.Range("G" & Rows.Count).End(xlUp).Row + 1
　　　　　　　If dstSheet.Range("E1") = "" Then
　　　　　　　　　dstRow = 1
　　　　　　　End If
　　　　　　　dstSheet.Range("E" & dstRow).Resize(1, 3).Value = _
　　　　　　　　　　srcSheet.Range("E" & srcRow).Resize(1, 3).Value
　　　　　Else
　　　　　　　dstSheet.Range("E" & obj.Row).Resize(1, 3).Value = _
　　　　　　　　　　srcSheet.Range("E" & srcRow).Resize(1, 3).Value
　　　　　End If
　End If
Next

End Sub
'---------------------------------------

変数の型はObjectではなく明示した方がベターです。
また、ちゃんと目的に合った型を宣言すること。
それから、nameという変数はあまり感心しません。
以上。

　

この回答へのお礼

目的にあったプログラムでした。
是非、使わせて頂きたいと思います。

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

お礼日時：2009/01/24 16:21

No.3 回答者： o_chi_chi 回答日時： 2009/01/22 20:53

たびたび失礼します。

With Sheets(dstSheet)
そもそもこの行必要ないと思いますけど。。。

No.2 回答者： o_chi_chi 回答日時： 2009/01/22 20:46

これでどうでしょう。

---
With Sheets(dstSheet) '←これに対応するEnd Withがない
dstSheet.Range("E" & lngYLine).Resize(1, 3).Value = srcSheet.Range("E" & srcRow).Resize(1, 3).Value 'データ転記(4)
End With '←追加

No.1 回答者： o_chi_chi 回答日時： 2009/01/22 18:13

If dstSheet.Range("E2") = "" Then dstRow = 1

この１行でIfは完結し、その下のEnd Ifは(3)のIf文の終了と判断されています。
If dstSheet.Range("E2") = "" Then
dstRow = 1
こうすればOK
ところで
If obj Is Nothing Then
このIf文は（転記先シート名）が空白の場合も判定されTrueになりますけど大丈夫ですか。

この回答への補足

回答ありがとうございます。

If dstSheet.Range("E2") = "" Then dstRow = 1
↓
If dstSheet.Range("E2") = "" Then
dstRow = 1

で変更しましたが
それでも、IF文のところでひっかかってしまいますね。

補足日時：2009/01/22 19:24