[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『削除候補の指定文字列にワイルドカードを利用』（がんべーる）
以下の質問の派生になります。
https://www.excel.studio-kazu.jp/kw/20240121114726.html
調子に乗って削除候補の指定文字列をB4より下方向書き出していったら
20を超えてしまいました。
よく見ると kimura_456 kimura-236 kimura_(S653
などのようにkimuraで始まるのでこれはワイルドカードを利用すれば一つに出来るのではと考えました。
B列にワイルドカードを利用して
上記のkimura??????を登録したいのですが
どのような文字列を登録すれば良いですか？
又、コードの修正も必要だと思いますが
Replace関数でワイルドカードを利用した場合は
NewName = Replace(NewName, Target(i), "")
はどのようになりますか？
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
VBAのReplace関数でワールドカードは使えません。(Replaceメソッドと混同されているのかな）
"正規表現"をご存じであれば、そうした置換ができると思います。
条件を明確にする必要がありますね。 ・kimuraの後はなんでもよくて、kimuraから始まる文字列は""に置換するんですか？ ファイル名対象だと、拡張子も消してしまっていいんですか？ ・ワイルドカードを使わないものも残るのですね？ 二方式を使い分けると。 ・置換したあとで重なってしまうものなどはないのですね。
# 色々考えると、今の方式がよいかも、となる気もします。
（xyz） 2024/01/22(月) 10:42:56
別の方法として、ファイル名をシートに展開しておけば、Replaceメソッドでワイルドカードが使えます。 置換前、置換後のファイル名を作ってから、あとは、 (1)fsoのMoveFile または、 (2)VBAのNameステートメント でパス名を変更すればよいかもしれません。 （xyz） 2024/01/22(月) 10:55:18
ありがとうございます。
Replace関数でワールドカードは使えないのですね。
Replaceメソッドなら使えるようなので勉強してみます。
条件が明確では無いとのご指摘なので質問に以下のように回答します。
＞kimuraの後はなんでもよくて、kimuraから始まる文字列は""に置換するんですか？
そうです。
＞ファイル名対象だと、拡張子も消してしまっていいんですか？
拡張子は、元のままで消えては困ります。
＞ワイルドカードを使わないものも残るのですね？
これは、kimura とkimura??????があるとすれば
kimura??????だけを削除してkimuraは残すとの意味ですよね？
想定では、削除される文字列側に削除同じ文字が複数ある事は無いです。
（がんべーる） 2024/01/22(月) 11:04:43
回答ありがとうございました。 >Replaceメソッドなら使えるようなので勉強してみます。 頑張ってください。
（xyz） 2024/01/22(月) 11:24:36
Replaceメソッドの指定が上手く処理できません。
ModFileName = ws1.Cells(i, "B").Replace(DelMojis, "", OrigFileName)
どのように変更すべきですか ？
なおこのコードでは、削除すべき文字列が２つある事は考慮していないので
その後の修正点になると思います。
Option Explicit
Sub ファイル名を書き出す()
Dim Fso As Object 'FileSystemObject
Dim Folder As Object 'Folder
Dim File As Object 'File
Dim FolderPath As String 'フォルダパス
Dim OldName As String '元のファイル名
Dim NewName 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:\Users\TAC_\Downloads\"
'Folderオブジェクトを取得
Set Folder = Fso.GetFolder(FolderPath)
Worksheets("Target").Cells.Clear
Range("A1") = "元ファイル名"
Range("A1").Font.Bold = True
Range("B1") = "修正後のファイル名"
Range("B1").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", "mp3", "flac", "wav"
'ファイル名を出力
ws1.Cells(num, "A").Value = File.Name
num = num + 1
Case Else
End Select
Next
ws1.Columns("A:B").AutoFit
'--------------------------------------------------------
'ワイルドカードを使って置換()
Dim OrigFileName As String
Dim ModFileName As String
Dim DelMojis As String
Dim lc1 As Long, lc2 As Long, i As Long, ii As Long
lc1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lc2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lc1
OrigFileName = ws1.Cells(i, "A")
For ii = 2 To lc2
DelMojis = ws2.Cells(ii, "B")
ModFileName = ws1.Cells(i, "B").Replace(DelMojis, "", OrigFileName)
ws1.Cells(i, "B").Value = ModFileName
Next
Next
End Sub
（がんべーる） 2024/01/22(月) 14:06:38
・A列には 拡張子を除いたいわゆるBaseName（fso.GetBaseNameで取得可能です）を並べ、 ・B列には 拡張子を 並べます。
・A列のセル範囲をまとめて対象にして、置換します。 (ここはマクロ記録でもとれば分かりますよ） ・これを置換文字列の数だけ繰り返します。
・変換後のBaseNameと拡張子を連結して、変換後のファイル名とします。
こんなストーリーじゃないですか？
# 外出しますので、少しアクセスできません。 （xyz） 2024/01/22(月) 14:22:51
ワイルドカードは例えば、"kimura*"として、LookAt:=xlPartとして ""にReplaceすれば、 "kimura"以下の文字列を消すことができます。 拡張子まで消さないように、Basenameとextensionは別セルにするのです。 （xyz） 2024/01/22(月) 16:32:37
なんかエラーの出ないところまでは出来ました。
不具合等アドバイスあればお願いします。
一つ前の書き込みで
「削除すべき文字列が２つある事は考慮していないので その後の修正点になると思います。」と記載しましたが
よくよく考えてみると必要無いと思われますが？
どうでしょうか？
Option Explicit
Sub ファイル変更_部分削除()
Dim Fso As Object 'FileSystemObject
Dim Folder As Object 'Folder
Dim File As Object 'File
Dim FolderPath As String 'フォルダパス
Dim OldName As String '元のファイル名
Dim NewName 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:\Users\TAC_\Downloads\"
'Folderオブジェクトを取得
Set Folder = Fso.GetFolder(FolderPath)
Worksheets("Target").Cells.Clear
Range("A1") = "修正後のファイル名"
Range("A1").Font.Bold = True
Range("B1") = "拡張子"
Range("B1").Font.Bold = True
Range("C1") = "元ファイル名_退避"
Range("B1").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", "mp3", "flac", "wav"
'元ファイル名及び同拡張子を出力
ws1.Cells(num, "A").Value = Fso.GetBaseName(File.Name)
ws1.Cells(num, "B").Value = Fso.getextensionname(File.Name)
num = num + 1
Case Else
'n = n + 1 '変名が必要でない場合ファイルをカウント
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
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
'----------------------------------------
'ファイル名変更
For i = 2 To lc1
With ws1
Name FolderPath & .Cells(i, "C") & "." & .Cells(i, "B") As FolderPath & .Cells(i, "A") & "." & .Cells(i, "B")
End With
Next
End Sub
（がんべーる） 2024/01/22(月) 16:38:09
> 「削除すべき文字列が２つある事は考慮していないので > その後の修正点になると思います。」と記載しましたが file1kimuraxx.xlsx file1kkmurayy.xlsx のようなファイルがあると、二つ目の奴はfile1.xlsx重なってしまってファイル名変更ができない恐れ。 こういうことは無いんですよね、という意味でした。無ければ無視して結構です。 うまく動作しているならそれでよろしいのでは？ テスト検証は私の仕事ではないです。
（xyz） 2024/01/22(月) 16:55:58
自分では気が付かない点があるかなと思いましたが
問題が出たら又相談します。
xyzさん、お付き合い願いありがとうございます。
（がんべーる） 2024/01/22(月) 17:07:52
解決済みみたいですが、せっかく作成したので置いておきます。
ファイル名から指定の文字列以降を削除する関数を作成してみました。 ただし拡張子は残します。
Public Function ExtractFileName(FileName As String, DelStr As String) As String
Dim BaseName As String, extName As String, p As Long
p = InStrRev(FileName, ".")
If p > 0 Then
extName = Mid(FileName, p)
BaseName = Left(FileName, p - 1)
Else
BaseName = FileName
End If
p = InStrRev(FileName, DelStr)
If p > 0 Then
BaseName = Left(BaseName, p - 1)
End If
ExtractFileName = BaseName & extName
End Function
使用例 Dim OldName As String, DelStr As String, NewName As String OldName = "ABCDEkimura_456.ext" DelStr = "kimura" NewName = ExtractFileName(OldName, DelStr) Name FolderPath & OldName As FolderPath & NewName
（hatena） 2024/01/22(月) 17:39:38
正規表現を利用した方法の骨子を書いて見ます。
(hatenaさんのクールなコードのあとで気が引けますね。 正規表現に興味をお持ちのかたの参考になれば幸いです。）
・拡張子を分離することなく、パターンで判別することとしています。 ・パターンを一つ作ることで、すべてのファイルを相手にすることができます。
Option Explicit
Dim re As Object
Sub test()
Dim pat As String
Dim ary As Variant
Dim r As Range
'test用データ(例) 実際は手で、セル範囲に設定しておくことになります。
[A1] = "aa.*" '任意の文字列は .* と書きます
[A2] = "bb.*"
[A3] = "cc" 'ワイルドカード不使用
[A4] = "\(.*" ' ()は特殊文字なので、\でExcapeします。
'正規表現の設定
ary = Application.Transpose(Range("A1:A4").Value) 'テストにつき固定。要修正。
pat = Join(ary, "|")
pat = "(.*?)" _
& "(" & pat & ")" _
& "([^\.]*?)" _
& "(\..*)"
Debug.Print pat '確認 => (.*?)(aa.*|bb.*|cc|\(.*)([^\.]*?)(\..*)
'↑拡張子部分
Set re = CreateObject("VBScript.RegExp")
re.Pattern = pat
'テスト検証 ↓置換前 ↓置換後 想定結果と同等であることを確認しています。
Debug.Assert myReplace("file1aa100.csv") = "file1.csv"
Debug.Assert myReplace("file2bb200.csv") = "file2.csv"
Debug.Assert myReplace("file3cc.csv") = "file3.csv"
Debug.Assert myReplace("file4ccd.csv") = "file4d.csv"
Debug.Assert myReplace("file5.csv") = "file5.csv" 'マッチしない場合は入力値が返される
Debug.Assert myReplace("test(100).csv") = "test.csv"
'不一致があるとそこでストップしますが、ストップしないのでOKであることが判明。
End Sub
Function myReplace(s) As String
myReplace = re.Replace(s, "$1$3$4")
End Function
# "牛刀をもって鶏を割く"を地で行く感じかなあ。 （xyz） 2024/01/23(火) 09:21:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.