• ベストアンサー
  • 困ってます

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

  • 質問No.4651618
  • 閲覧数1612
  • ありがとう数2
  • 回答数4

お礼率 47% (35/74)

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


・ボタン1をクリックすると、base(転記元)のG列に書かれた事項と同一のシート(転記先)へ転記する(各シートA,B,Cへ転記)
・転記先のE列を見て、既存のものであれば、上書きする
・転記先の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
  • ベストアンサー

ベストアンサー率 59% (228/384)

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

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

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

 
お礼コメント
defmerube

お礼率 47% (35/74)

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

ありがとうございました!
投稿日時:2009/01/24 16:21

その他の回答 (全3件)

  • 回答No.3

ベストアンサー率 45% (131/287)

たびたび失礼します。

With Sheets(dstSheet)
そもそもこの行必要ないと思いますけど。。。
  • 回答No.2

ベストアンサー率 45% (131/287)

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

ベストアンサー率 45% (131/287)

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

お礼率 47% (35/74)

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

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

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

で変更しましたが
それでも、IF文のところでひっかかってしまいますね。
投稿日時:2009/01/22 19:24
関連するQ&A

その他の関連するQ&Aをキーワードで探す

ページ先頭へ