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

質問

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

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

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

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

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

以下に作成したプログラムを記述します。
が、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 · ベストアンサー

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

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

'-----------------------------------------
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という変数はあまり感心しません。
以上。

お礼

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

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

回答No.3

o_chi_chi

たびたび失礼します。

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

回答No.2

o_chi_chi

これでどうでしょう。
---
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

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文のところでひっかかってしまいますね。