別ブックにデータを転記、蓄積したいのですが、一部のみ何度も転記されてしまいます。

Question

前提・実現したいこと

二種類のブックA,Bを使用し、Bに記入した複数行のデータをAに転記、蓄積できるシステムを作っているいます。一部のみ何度も転記されてしまうので、余分な転記がなくなるようなコードを書きたいです。

昨日teratailにてアドバイスいただき、無事転記システムを作成することができたのですが、その後自身で転記部分を追加したところ、以下のような問題が発生してしまいました。以下拙い説明かと思いますが、不明瞭な点があれば追記致しますので、皆様のご指摘、アドバイスいただければ大変嬉しいです。

発生している問題・エラーメッセージ

以下のコードでブックBからブックAに転記を行なっています。昨日teratailにてアドバイスいただき、太字部分（C1, C2, J2の転記部分）以外の転記コードを無事に作成いただくことができました。ブックBのC1, C2およびJ2に記載される内容もブックAのデータベースに転記しようと思い追記したところ、C1, C2およびJ2のみ何度も転記されるようになりました。余分な転記回数は初回25回だったのですが、試すごとに26回、27回と増えていきます。エラーメッセージは出ておりません。

該当のソースコード

Sub Transfer()

> ブックAにデータを蓄積していくため、ブックAの最終行を取得するためのgを指定しました。
 g = Workbooks("A.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Row + 1

> ブックBの6行目から最終行目までの全てのデータを転機するため、ブックBの行をiとして指定し、For Nextを利用しました。
 Dim i
 For i = 6 To Cells(Rows.Count, 1).End(xlUp).Row
  With Workbooks("B.xlsx").Worksheets("Input")
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("A" & g) = .Range("A" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("b" & g) = .Range("B" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("c" & g) = .Range("C" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("d" & g) = .Range("D" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("e" & g) = .Range("E" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("f" & g) = .Range("F" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("g" & g) = .Range("G" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("h" & g) = .Range("H" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("i" & g) = .Range("I" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("j" & g) = .Range("J" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("k" & g) = .Range("K" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("l" & g) = .Range("L" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("m" & g) = .Range("M" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("n" & g) = .Range("N" & i)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("o" & g) = .Range(**"C1"**)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("p" & g) = .Range(**"C2"**)
   Workbooks("A.xlsm").Worksheets("Sheet1").Range("q" & g) = .Range(**"J2"**)
 End With
 g = g + 1
 Next i

End Sub

試したこと

Debug StepInを利用して最初から確認したところ、For i = 6 To Cells(Rows.Count, 1).End(xlUp).Rowで6行目から末行までの転記は問題なく行われます。しかしその後もループが循環し、ブックBのC1,C2,J2のみが何度も転記されてしまいます。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[hatena19]

確認ですが、やりたいことは、説明では、
ブックB のデータを ブックA に転記することですよね。
しかし、コードを見ると、
ブックB の Inputシートのデータを、
ブックB の Sheet1 に転記するコードになってます。
提示のコードは実際に実行したコードに間違いないですか。

説明とコードが合致するように訂正してもらえませんか。

[neconekocat]

明らかに自分が実行したコードと違うものを記載してるので問題点を指摘しようがないですね。

[neconekocat]

本　当　に　自分が実行したコードを記載していますか？
前回の質問を見に行ったらベストアンサーはこのような回答をされていましたよ？
For i = 6 To Cells(Rows.Count, 1).End(xlUp).Row
Workbooks("A.xlsm").Worksheets("Sheet1").Range("A" & g) = .Range("A" & i)
'略
g = g + 1
Next i

余計な編集なんてせずにVBEに書いてあるコードをそのままコピペしてください。

[neconekocat]

では最後に1つ、Sub Transfer()が書かれているのはA.xlsmかB.xlsmかを記載してください。

Answer 1

提示コードが正しい前提ですが、恐らくはこれで正常に動くのかと

'For i = 6 To Cells(Rows.Count, 1).End(xlUp).Row
'  With Workbooks("B.xlsx").Worksheets("Input")

With Workbooks("B.xlsx").Worksheets("Input")
 For i = 6 To .Cells(.Rows.Count, 1).End(xlUp).Row

Comments

[harryban]

無事余分な転記なくシステムを作ることができました。ご丁寧にご対応いただき、本当にありがとうございました。