変名が思うように処理されないのは ？

質問

現在、以下のようなコードでA列のファイル名に指定の不要文字が含まれる場合、削除して変名を行っています。

エラーは出ないのですが、同名チェックが想定と違うのか上手く処理できていません。

具体的には、
不要文字が無いのに(１)が追加されて変名される場合があります。

不具合の原因が判るでしょうか？

Option Explicit

Sub ファイル変更_部分削除()

Dim Fso As Object 'FileSystemObject
Dim Folder As Object 'Folder
Dim File As Object 'File
Dim FolderPath As String 'フォルダパス

Dim Target As Variant '削除したい文字列
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Worksheets("Target")
Set ws2 = Worksheets("DEL")

'FileSystemObjectを作成
Set Fso = CreateObject("Scripting.FileSystemObject")

'フォルダパスを指定
FolderPath = "C:\Target\"

'Folderオブジェクトを取得
Set Folder = Fso.GetFolder(FolderPath)

Worksheets("Target").Cells.Clear

ws1.Range("A1") = "修正後のファイル名"
ws1.Range("A1").Font.Bold = True

ws1.Range("B1") = "拡張子"
ws1.Range("B1").Font.Bold = True

ws1.Range("C1") = "元ファイル名_退避"
ws1.Range("C1").Font.Bold = True

Dim ext As String
Dim num As Long
num = 2

For Each File In Folder.Files

ext = Fso.getextensionname(File.Name)

Select Case ext
Case "ts", "mkv", "mp4"

'元ファイル名及び同拡張子を出力
ws1.Cells(num, "A").Value = Fso.GetBaseName(File.Name)
ws1.Cells(num, "B").Value = Fso.getextensionname(File.Name)

num = num + 1

Case Else

End Select
Next

Dim lc1 As Long, lc2 As Long
lc1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row '最終行番号の取得
lc2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row

'元ファイル名を退避
ws1.Range(ws1.Cells(2, "A"), ws1.Cells(lc1, "A")).Copy
ws1.Cells(2, "C").PasteSpecial

ws1.Columns("A:C").AutoFit

'--------------------------------------------------------
'Replacedメソッド / ワイルドカードを使って置換()

Dim DelMojis As String '指定文字列を格納する変数
Dim i As Long
Dim Fix1 As String

For i = 2 To lc2

With ws1
.Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=Fix1, Replacement:="", LookAt:=xlPart
End With
Next

For i = 2 To lc2
DelMojis = ws2.Cells(i, "B") '指定文字列を変数に代入

With ws1
.Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=DelMojis, Replacement:="", LookAt:=xlPart
End With
Next

'----------------------------------------
'ファイル名変更
Dim OldName As String '元のファイル名
Dim NewName As String '新しいファイル名

For i = 2 To lc1
With ws1
OldName = FolderPath & .Cells(i, "C") & "." & .Cells(i, "B")
NewName = FolderPath & .Cells(i, "A") & "." & .Cells(i, "B")
End With

With Fso 'fso=CreateObject("Scripting.FileSystemObject")

'移動先に同名のファイルがあるかチェック
If .FileExists(NewName) Then
' 同名がある場合は、NewNameの最後に(1)を追加する
Dim k As Long
k = InStrRev(NewName, ".")
NewName = Left(NewName, k - 1) & "(1)" & Right(NewName, Len(NewName) - k + 1)
.MoveFile OldName, NewName
Else
'ファイルを移動
.MoveFile OldName, NewName
End If

End With

'--------------------------
Next
End Sub

回答No.5

kkkkkm · ベストアンサー

> 苦肉の策で以下のようにGotoで処理を飛ばすようにしましたが

If OldName <> NewName Then

で実行部分を囲むという手もあると思いますが、好みになるのかもしれませんね。

移動しないとか移動はファイル名を変更したものだけだとかでしたら、それでいいと思います。
.MoveFileだと個人的には移動のイメージなので移動しないのでしたらNameステートメントとかがしっくりきます。

お礼

アドバイス、ありがとうございます。

＞ If OldName <> NewName Then

Gotoが無くなる上記にコードを変換しました。

コードを修正する事に重きを置いていましたが
最初から思考を替えて新しくコードを考え直した方がすっきりしそうなの切り替えます。

.＞MoveFileだと個人的には移動のイメージなので
＞移動しないのでしたらNameステートメントとかがしっくりきます。

変名にMoveではなくNameを利用する方がしっくりくるのはわかります。

以前は、変名の場合はすべてNameで処理していたのですが
ある時、FOSに環境依存文字があると処理できないケースに遭遇して
Moveを利用するようにしました。

回答No.4

kkkkkm

> １）変名前のファイル名にDelmojiが存在していて
> 　　Delmojiを削除した場合のファイル名だけを対象にした場合に
> 　　同名のファイルが存在するかをチェックする必要があると思います。

移動なのに同じフォルダでいいのかなとも思いましたが、別フォルダにするとして移動先に名前を変更する必要のないファイルが存在しないのでしたら(おおきな背中.mp4みたいなファイル)NewNameのフォルダを違うものにすればいいと思います。

他には、A列とC列と比較して同じなら

If .FileExists(NewName) Then

を実行しなければいいと思いますし

.Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=DelMojis, Replacement:="", LookAt:=xlPart

で一括で置換してますが InStrでDelMojisがあれば置換して修正したファイル名だけの一覧を作るとかもあると思います。

回答No.3

kkkkkm

> すでに　大きな背中.mp4　がある場合は
> 　おおきな背中(1).mp4　となります。

漢字がひらがなにですか、それは無いと思いますが

修正後のファイル名
に修正していないファイル名も存在していて、同じフォルダで重複チェックしているので引っかかると思いますという事です。

お礼

苦肉の策で以下のようにGotoで処理を飛ばすようにしましたが
これで十分でしょうか　？

For i = 2 To lc1
With ws1
OldName = FolderPath & .Cells(i, "C") & "." & .Cells(i, "B")
NewName = FolderPath & .Cells(i, "A") & "." & .Cells(i, "B")
End With

'新しいファイル名 (置換後)と元ファイル名が同じなら
'置換されていないので以後の処理は必要ないのでSKIP
If OldName = NewName Then
GoTo skip
End If

With Fso 'fso=CreateObject("Scripting.FileSystemObject")

'移動先に同名のファイルがあるかチェック
If .FileExists(NewName) Then
' 同名がある場合は、NewNameの最後に(1)を追加する
Dim k As Long
k = InStrRev(NewName, ".")
NewName = Left(NewName, k - 1) & "(1)" & Right(NewName, Len(NewName) - k + 1)
.MoveFile OldName, NewName
Else
'ファイルを移動（変名)
.MoveFile OldName, NewName

End If

End With
skip:
'--------------------------
Next

補足

＞漢字がひらがなにですか、それは無いと思いますが

記載ミスです。

すいません。
つい、漢字変換してしまいました。

以下に訂正します。
↓
すでに　おおきな背中.mp4　がある場合は
おおきな背中(1).mp4　となります。

思うに以下の判断ですが
'移動先に同名のファイルがあるかチェック
If .FileExists(NewName) Then

これでは、不足で
１）変名前のファイル名にDelmojiが存在していて
　　Delmojiを削除した場合のファイル名だけを対象にした場合に
　　同名のファイルが存在するかをチェックする必要があると思います。

判断が込み入っているので
色々とコードを見直していますがまだ上手く処理できていません。

回答No.2

kkkkkm

フォルダの指定が
FolderPath = "C:\Target\"
だけなので
最後の「ファイルを移動」で
OldName = FolderPath & .Cells(i, "C") & "." & .Cells(i, "B")
NewName = FolderPath & .Cells(i, "A") & "." & .Cells(i, "B")
なので移動先も
"C:\Target\"
になってると思いますから変更されなかったファイルもそこにNewNameで存在しているのが原因じゃないかと思います。

.MoveFile OldName, NewName
のところを

ws1.Cells(i, "E").Value = OldName
ws1.Cells(i, "F").Value = NewName

にして確認してみてください。

変更したリストを作成してそこでNewNameを取り出したらいいのかなとも思えます。

お礼

アドバイスをありがとうございます。

moveを止めてE,F列にファイル名を書き出すようにしてチェックすると
どうもDelmojiが含まれていないファイル名でファイルが無くても
(1)が付加されるようです。

例えば、
Delmojiが[Jap]だとすれば
変名は、ファイルが存在しないなら
　[jap]おおきな背中.mp4 ----> おおきな背中.mp4　となりますが、

すでに　大きな背中.mp4　がある場合は
　おおきな背中(1).mp4　となります。

回答No.1

kkkkkm

> For i = 2 To lc2
>
> With ws1
> .Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=Fix1, Replacement:="", LookAt:=xlPart
> End With
> Next

Fix1に何も代入されていないと思うのですが、これでいいのでしょうか…。

補足

>Fix1に何も代入されていないと思うのですが、これでいいのでしょうか…。

失礼しました。

Fix1 －－→ Delmojis　

問題にされたwith ws1の部分は、開発途中の古いコードを間違ってUPしたもので
そのコードの下にあるwhat:=DelMojisの元になる部分で必要ないコードになります。

全て削除してください。