ファイル名を合成すると検索できないのでしょうか？

質問

下記のような式がありまして、一度作成したファイルは上書きされないはずですが何回やっても上書きされてしまいます。
これはファイルを検索していないのでしょうか？
既にファイルがあったら終了するはずですが何か間違えていますか？

'ファイル作成
Sub MakeCopyFile(newfile As String, orgfile As String)
If SearchFile(newfile) Then
Exit Sub
End If

Set fs = CreateObject("Scripting.FileSystemObject")

fs.CopyFile orgfile, newfile
End Sub

' ファイル検索
Function SearchFile(fname As String) As Boolean
SearchFile = False
Set fs = Application.FileSearch
With fs
.Filename = fname
If .Execute() > 0 Then
SearchFile = True
End If
End With
End Function

Sub Macro1()

Dim name As String '名前
Dim fname As String 'ファイル名
Dim directory As String '作成先ディレクトリ
Dim fullpath As String 'フルパス
Dim orgfile As String '雛形のファイル名
Dim editbook As Workbook '個人データブック
Dim id As String '番号

directory = "H:\test\"
orgfile = "H:\test\雛形.xls"

For i = 1 To 100

name = ThisWorkbook.Worksheets("Sheet2").Cells(i, 10).Value
id = ThisWorkbook.Worksheets("Sheet2").Cells(i, 12).Value
If name = "" Then

Exit For

End If

'コピーしたファイルを作成する
fname = name + id + ".xls" 'ファイル名合成
fullpath = directory + fname 'フルパス合成
Call MakeCopyFile(fullpath, orgfile) 'ファイル作成

Workbooks.Open Filename:=fullpath
Set editbook = Workbooks(fname)

editbook.Worksheets("Sheet3").Cells(8, 14).Value = name
editbook.Worksheets("Sheet3").Cells(8, 10).Value = id
'※(その他必要な処理があれば追加してください)

editbook.Close (True)
Next i
End Sub

回答No.1

lark_0925 · ベストアンサー

FileSearchオブジェクトは、バグがいくつもあると聞いていますし、
Excelの新しいバージョンでは、なくなっています。
私は、ＯＳのファイル管理にアクセスするなら、ちょっと遅くても
FileSystemObjectを使っています（簡単ですから・・・）。
今回のファイルの存在の有無なら、FileSystemObjectを
使ったほうが良いと思いますが、投稿されたコードは、
FileSearchオブジェクトの使用方法が間違っているみたいですよ！！

Function SearchFile(fname As String) As Boolean
　　Dim g0 As Long
　　Dim fs As FileSearch
　　Dim wk As Variant
　　Dim pathnm As String
　　wk = Split(fname, "\")
　　pathnm = ""
　　For g0 = LBound(wk) To UBound(wk) - 1
　　　If g0 < UBound(wk) - 1 Then
　　　　　pathnm = pathnm & wk(g0) & "\"
　　　Else
　　　　　pathnm = pathnm & wk(g0)
　　　　　End If
　　　Next
　　SearchFile = False
　　Set fs = Application.FileSearch
　　With fs
　　　.NewSearch
　　　.LookIn = pathnm
　　　.Filename = wk(UBound(wk))
　　　If .Execute() > 0 Then
　　　　　SearchFile = True
　　　　　End If
　　　End With
　　Erase wk
End Function

投稿されたコードを使って修正するとこんなことになりました。

更にファイルコピーを行う前のオーバーライトのチェックのための
「ファイルの存在の有無」なら、FSO（FileSystemObject）のCopyFileメソッドなら、オーバーライトの許可の有無というオプションがあります。
よって、
上書きをゆるさないファイルコピーなら、
'==================================================
Sub test()
　　Dim a, b
　　a = Application.GetOpenFilename
　　b = Application.GetSaveAsFilename
　　MsgBox cpfile(a, b)
End Sub
'=================================================
Function cpfile(a, b) As Variant
　　On Error Resume Next
　　With CreateObject("scripting.filesystemobject")
　　　.CopyFile a, b, False
　　　End With
　　cpfile = Err.Number
　　If cpfile <> 0 Then
　　　cpfile = Err.Description
　　　End If
End Function

この程度でも良いと思いますが、検討してみてください。

補足

早速のご回答誠にありがとうございます。

sub又はfunctionが定義されていません。となり

Call MakeCopyFile(fullpath, orgfile) 'ファイル作成

のところでとまってしまうんですがここに何か入れるんでしょうか？

下記のコードは修正して使用するのでしょうか？
このまま使用するとfnameを見ていないような気がするのですが・・・
初心者ですみません。

回答No.2

lark_0925

>sub又はfunctionが定義されていません。となり
>Call MakeCopyFile(fullpath, orgfile) 'ファイル作成
>のところでとまってしまうんですがここに何か入れるんでしょうか？
それは、MakeCopyFileというFunctionまたは、プロシジャーが
存在しないからです。

再度投稿です。

新規ブック（あくまでも新規ブックであってwingupさんが抱えている問題のブックでありません）の標準モジュールに

Sub test()
　　Dim a, b
　　a = Application.GetOpenFilename
　　b = Application.GetSaveAsFilename
　　MsgBox cpfile(a, b)
End Sub
'=================================================
Function cpfile(a, b) As Variant
　　On Error Resume Next
　　With CreateObject("scripting.filesystemobject")
　　　.CopyFile a, b, False
　　　End With
　　cpfile = Err.Number
　　If cpfile <> 0 Then
　　　cpfile = Err.Description
　　　End If
End Function

でtestを実行して新規コピーが出来て、
上書きコピーが出来ないことを確認してください。

確認後、このcpfileというFunctionを実際に今抱えているブックで
運用することを考えてください。

私が協力できるのは、ここまでです。

お礼

すみません大変ありがとうございました。