フォルダを統合した時に同名ファイルが有った場合、「同名のファイルが有ります・・・。」というメッセージボックスを表示させたい。

前提

以下のコードを使って、2つのフォルダを統合し、追加したデータをﾌｫﾙﾀﾞごと「追加ﾃﾞｰﾀ」というフォルダに移動しています。
エラー等はなく正常に作動するのですが、同名のファイルが有った場合に自動で上書き保存されてしまいます。

実現したいこと

同名のファイルが有った場合に「同名のファイルがあります・・・。」の表記が表示される。
又は「ファイル名（1）」の様に自動で名前を変えて保存したい。
若しくは同名のファイルが有った場合は移動しない。

試したこと

Do while　や for文等を使い、ファイルを循環させれば実現可能なのですが、そもそもVBA上でエクセルを保存する時の様に、上書きする際に、「fso.CopyFolder」の設定等を指定出来ないかと思い質問致しました。

ちなみに主導でフォルダをドラッグ&ドロップすると、「同名のファイルが存在します・・・」というメッセージが表示され、上書き「置き換え」するか選択できます。

以下がそのコードです。下から5行目に「fso.CopyFolder」を使っております。

よろしくお願いします。

Sub データ上書き()
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 adname = "初期値"
 Row = 6

 Do While adname <> ""
  adname = Cells(Row, 2) & "\" & Cells(Row, 1)
  addit = ThisWorkbook.Path & "\追加ﾃﾞｰﾀ" & "\" & Cells(Row, 1)
   
  If adname = "\" Then
   Exit Do
  End If
  
  b = fso.FolderExists(adname)
  c = fso.FolderExists(addit)
  If b = False Then
   MsgBox "注意！！！移動先(重要ﾃﾞｰﾀ)のﾌｫﾙﾀﾞが有りません｡" & Cells(Row, 1) & "のURLを確認して下さい。"
   End
  ElseIf c = False Then
   MsgBox Cells(Row, 1) & "の追加ﾃﾞｰﾀが存在しません。"
   End
  End If
  fso.CopyFolder addit, adname
  
   '異動済みﾌｫﾙﾀﾞ
   lastfol = ThisWorkbook.Path & "\過去追加ﾃﾞｰﾀ" & "\" & Format(Date, "yyyymmdd")
   
   b = fso.FolderExists(lastfol)
   If b = False Then 'ﾌｧｲﾙ無かったら移動
    MkDir lastfol
    fso.MoveFolder addit, lastfol & "\" & Cells(Row, 1)
   Else 'フォルダが有ったらコピー&削除
    fso.CopyFolder addit, lastfol & "\" & Cells(Row, 1)
    fso.deletefolder addit
   End If

  Row = Row + 1
 Loop
 
End Sub

行動規範の内容に同意します

回答2件

片方のフォルダのファイルリストを取得
ファイル名を取り出し、もう片方にそのファイルが存在しているかをチェック
存在している場合はダイアログを出し、確認
ファイルのコピー
ファイルが尽きるまで２から繰り返し

という実装になるかと。

投稿2022/11/12 13:33

y_waiwai

総合スコア87784

ベストアンサー

CopyFolder の第３引数にFalseを設定すると上書きされません。同名のファイルが存在するときはエラーが発生します。（詳細は下記参照）

CopyFolder メソッド (Visual Basic for Applications) | Microsoft Learn

同名のファイルが有った場合に「同名のファイルがあります・・・。」の表記が表示される。
又は「ファイル名（1）」の様に自動で名前を変えて保存したい。
若しくは同名のファイルが有った場合は移動しない。

「同名のファイルが有った場合は移動しない」でいいのなら、エラーが出たら、エラーを無視して次の処理に進むようにすればいいでしょう。

vba
1    'フォルダが有ったらコピー&削除
2    On Error Resume Next 
3    fso.CopyFolder addit, lastfol & "\" & Cells(Row, 1)
4    If Err.Number = 58 Then
5        MsgBox "同名ファイルがあるのでコピーできません。"  & vbCrLf & _ 
6                    "コピー元:" &  addit  & vbCrLf & _
7                    "コピー先:" &   lastfol & "\" & Cells(Row, 1)
8        Err.Clear
9    Else
10        fso.deletefolder addit
11    End If
12    On Error Goto 0