貼り付けた値が消えていく 以下はソースファイルの2番目のシートのB6から最終行を取得 ターゲットファ

貼り付けた値が消えていく

以下はソースファイルの2番目のシートのB6から最終行を取得
ターゲットファイルの"売上予測推移"シートのB6から最終行を取得
その中に同じ値があったら、ソースファイルの2番目のシートの同じ値があったセルの同じ行のC列～J列の5つのセルの値をコピーして
ターゲットファイルの同じ値のセルの隣のC列に貼り付けるものです。
複数のソースファイルを取り込むと、なぜか最後に取り込んだソースファイルの値だけターゲットファイルに貼りついています。
つまり以前に貼りついた値が丸々消えてます。
どうすれば解決できますでしょうか？お詳しい方宜しくお願い致します。



Sub 同じ値で貼り付け()

Dim sourcePath As String
Dim targetPath As String
Dim targetFileNamePart As String
Dim targetFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim sourceValue As Variant
Dim targetValue As Variant
Dim lastRowSource As Long
Dim lastRowTarget As Long
Dim i As Long
Dim j As Long
Dim foundRow As Long
Dim fileName As String

' ソースファイルのパス
sourcePath = "C:\Users\225\Desktop\テスト\"

' ターゲットファイルのパス
targetPath = "C:\Users\225\Desktop\管理ファイル\"

' ターゲットファイルを探す部分文字列
targetFileNamePart = "営業用"

' 警告メッセージを非表示にする
Application.DisplayAlerts = False

' ソースフォルダ内のすべてのExcelファイルに対して処理を実行
fileName = Dir(sourcePath & "*.xlsx")
Do While fileName <> ""
' ソースファイルを開く（外部リンクが含まれている場合、リンクを更新せずに開く）
Set wbSource = Workbooks.Open(sourcePath & fileName, UpdateLinks:=False)

' ターゲットファイルを探す
targetFile = Dir(targetPath & "*" & targetFileNamePart & "*.xlsx")

' ターゲットファイルを開く（外部リンクが含まれている場合、リンクを更新せずに開く）
Set wbTarget = Workbooks.Open(targetPath & targetFile, UpdateLinks:=False)

' ソースファイルの2番目のシートを取得
Set wsSource = wbSource.Sheets(2)

' ターゲットファイルの"売上予測推移"シートを取得
Set wsTarget = wbTarget.Sheets("売上推移")

' ソースファイルの2番目のシートのB6から最終行を取得
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row

' ターゲットファイルの"売上予測推移"シートのB6から最終行を取得
lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row

' ソースファイルの2番目のシートのB6から最終行までループ
For i = 6 To lastRowSource
sourceValue = wsSource.Cells(i, "B").Value
foundRow = 0

' ターゲットファイルの"売上予測推移"シートのB6から最終行までループして、同じ値があるか確認
For j = 6 To lastRowTarget
targetValue = wsTarget.Cells(j, "B").Value
If sourceValue = targetValue Then
foundRow = j
Exit For
End If
Next j

' 同じ値が見つかった場合は、コピーして貼り付け
If foundRow > 0 Then
wsSource.Range("C" & i & ":J" & i).Copy
wsTarget.Range("C" & foundRow).PasteSpecial xlPasteValues
End If
Next i

' コピー元のシートとファイルを閉じる
wbSource.Close SaveChanges:=False

' ターゲットファイルを保存して閉じる
wbTarget.Close SaveChanges:=True

' 次のファイルを取得
fileName = Dir
Loop

' 警告メッセージを再度表示させる
Application.DisplayAlerts = True
End Sub

No.2 回答者： tatsumaru77 回答日時： 2023/07/28 09:02

現行のマクロでは、ソースファイルが複数あった時、正しくソースファイル名を取得できません。

マクロの構造を単純にかくと、以下のようになっています。
fileName = Dir(sourcePath & "*.xlsx")・・・①
Do While fileName <> ""
targetFile = Dir(targetPath & "*" & targetFileNamePart & "*.xlsx")・・・②
fileName = Dir・・・③
Loop

①で1件目のソースファイル名を取得
②でターゲットファイル名を取得
③で次のソースファイル名を取得

を行っているつもりかと思いますが、
③は、②で取得した設定を継続します。従って、実際には次のターゲットファイル名を取得しています。


対策ですが、
1案：
ターゲットファイルが1件しかないなら、dir関数を使わずに、直接、ファイル名を指定してオープンする。

2案：
ターゲットファイルが複数あるなら、最初にターゲットファイルのファイル名を取得しておく。

等が考えられます。


ターゲットファイルは1件だけなのでしょうか？
もし、1件だけなら、直接ファイル名を指定してオープンできないのでしょうか？
ターゲットファイルが複数なら、どのターゲットファイルに書き込むかという基準が明確に
なっていません。とにかく最初に取得したファイル名をに対して処理をすれば良いのでしょうか？

No.1 回答者： fujillin 回答日時： 2023/07/27 13:35

こんにちは

コードは見ていませんけれど・・・

＞なぜか最後に取り込んだソースファイルの値だけ
＞ターゲットファイルに貼りついています。
ご説明通りの処理内容になっているのであれば、当然の結果ではないでしょうか？

＞ターゲットファイルの同じ値のセルの隣のC列に貼り付けるものです。
とありますので、B列の同じキーが後から出てくれば、同じ位置に上書きすることになりますから、最後に記入したファイルの内容だけが結果として残ることになります。
（どこが疑問なのかがわかりません）

とは言っても、
＞以前に貼りついた値が丸々消えてます。
ということは無いと思います。
同じキーが出てくれば上書きされるでしょうし、同じキーが出てこなければ、記入したものはそのまま残っているはずと推測します。
（「丸々全部」は消えないだろうという意味です）

複数のファイル（＝ソースファイル）に同じキーが存在した場合に、どのような結果をお望みなのでしょうか？
まずは、それを明らかにすることが必要です。
明確にできたなら、そのような処理になるようにプログラムを修正なさればよいでしょう。