[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『fso.MoveFileで移動先に同じファイルがあるとき』（たま）
いつもお世話になっています
fso.MoveFileを使用しファイルを別フォルダにリネイムして移動するマクロを
作成したのですが、移動先に同名のファイルがある場合
エラーが出て止まってしまいます
これを回避するために同名のファイルがある場合
新規に保存するファイルに改訂付番を付けたいのです
AAA.xlsx
というデータを移動させたいのに
既に同名のデータがある場合
AAA-1.xlsx
としたいのです
どのようにしたらいいのでしょうか
＜ 使用 Excel：Excel2016、使用 OS：Windows7 ＞
つくったマクロを書き込んでください。 そしたらどこをなおせばいいか、回答がつくと思います。
なにも書き込まないと、回答者が一からサンプルコードを書くハメになるわけで．．． （´・ω・`） 2019/12/20(金) 11:21
過去に似たようなのがありました。 [[20130629111050]] 『VBA 保存時に同じ名前があった場合に、連番にする』 （ろっくん） 2019/12/20(金) 11:32
仰るとおり、MoveFileメソッドだとエラーになっちゃうようなので、私なら１こずつFileExistsメソッドで存在チェックをして、存在しているならCopyメソッドでリネームしながらコピー、存在しないならMoveメソッドで移動させて、（Copyメソッドの結果）残ったものはフォルダごと削除かなぁ・・なんて思いました。
（実際には削除しちゃうと怖いので、しばらくはフォルダごと"削除"フォルダに移動させるなどの安全策を取るかもですが）
MoveFileメソッド
http://officetanaka.net/excel/vba/filesystemobject/filesystemobject23.htm
→引数destinationにすでに同名ファイルが存在する場合はエラーになります。
FileExistsメソッド
http://officetanaka.net/excel/vba/filesystemobject/filesystemobject10.htm
→存在する場合はTrueを返します。
Copyメソッド
http://officetanaka.net/excel/vba/filesystemobject/file13.htm
Moveメソッド
http://officetanaka.net/excel/vba/filesystemobject/file15.htm
→FileオブジェクトのMoveメソッドは、FileSystemObjectオブジェクトのMoveFileメソッドと同じ働きをします。
（もこな２ ） 2019/12/20(金) 12:51
Sub ファイル名変更と移動A()
Dim fso As FileSystemObject
Dim a_row As Long
Dim pass_name As String
Dim kensaku1 As String
Dim f_name As String
Set fso = New FileSystemObject
kensaku1 = "\"
pass_name = Cells(2, 1).Value
F_Kazu = Len(Mid(pass_name, InStrRev(pass_name, kensaku1) + 1))
a_name1 = Left(pass_name, Len(pass_name) - F_Kazu - 1)
a_row = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a_row
pass_name2 = Cells(i, 1).Value
kPoint = InStrRev(pass_name2, ".")
kakutyousi = Right(pass_name2, Len(pass_name2) - kPoint + 1)
f_name = Cells(i, 2).Value & kakutyousi
Call fso.MoveFile(pass_name2, a_name1 & "\移動\" & f_name)
Cells(i, 1).Value = a_name1 & "\移動\" & f_name
Next i
Set fso = Nothing
End Sub
A2以下にファイルの格納場をフルパスで入れています
pass_name = Cells(2, 1).Value
B2以下にある品番でファイル名を変更します拡張子はもともとの拡張子を取得して入れています
f_name = Cells(i, 2).Value & kakutyousi
ファイルのある階層にある"移動"フォルダにデータを移動し、リネイムします
B2以下の品番が同じものがあるため付番を付けたいのです
ただし1ファイルしかないものには付番はつけません
B2以下の品番には変更できません
宜しくお願いいたします
ろっくん さん、もこな２ さん
アドバイスありがとうございます
上記内容で再度アドバイスいただけたら助かります
宜しくお願いいたします
（たま） 2019/12/20(金) 17:28
やり方はいろいろあると思いますが、 一例です。
Sub ファイル名変更と移動A()
Dim FSO As FileSystemObject
Dim a_row As Long
Dim pass_name As String
Dim kensaku1 As String
Dim f_name As String
Set FSO = New FileSystemObject
kensaku1 = "\"
pass_name = Cells(2, 1).Value
F_Kazu = Len(Mid(pass_name, InStrRev(pass_name, kensaku1) + 1))
a_name1 = Left(pass_name, Len(pass_name) - F_Kazu - 1)
a_row = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a_row
pass_name2 = Cells(i, 1).Value
kPoint = InStrRev(pass_name2, ".")
kakutyousi = Right(pass_name2, Len(pass_name2) - kPoint + 1)
f_name = Cells(i, 2).Value & kakutyousi
On Error GoTo Err_FileExist
Call FSO.MoveFile(pass_name2, a_name1 & "\移動\" & f_name)
On Error GoTo 0
Cells(i, 1).Value = a_name1 & "\移動\" & f_name
Next i
Set FSO = Nothing
Exit Sub
Err_FileExist:
Select Case Err.Number
Case 58
kPoint = InStrRev(f_name, ".")
kakutyousi = Right(f_name, Len(f_name) - kPoint + 1)
f_name = Left(f_name, Len(f_name) - Len(kakutyousi))
hpoint = InStrRev(f_name, "-")
If hpoint > 0 Then
fuban = Right(f_name, Len(f_name) - hpoint + 1)
If IsNumeric(fuban) Then
fuban = Val(fuban) - 1
f_name = Left(f_name, hpoint - 1) & fuban & kakutyousi
Else
f_name = f_name & "-1" & kakutyousi
End If
Else
f_name = f_name & "-1" & kakutyousi
End If
Resume
Case Else
Err.Raise Err.Number, , Err.Description
End Select
End Sub
（´・ω・`） 2019/12/20(金) 18:28
本当にありがとうございました
（たま） 2019/12/23(月) 10:52
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.