変名が思うように処理されないのは ？
現在、以下のようなコードで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
お礼
ありがとうございました。 願った結果になりました。本当に助かりました。