エクセルのマクロについて教えてください。

下記のマクロは以前教えて頂いたマクロで
マクロを実行すると
指定フォルダ内のサブフォルダ「0」～「9」までのフォルダに保存されている
PDFファイル名を半角英数字8文字に変更できます。
例えば
「ABC12345678」を「12345678」に変更
しかし、稀にファイル名が
「3-46(ABC-24000760).pdf
や
「(ABC-24000760).pdf」などなど
色々な文字の場合があります。
「3-46(ABC-24000760).pdfの場合でも「24000760」に
「(ABC-24000760).pdf」の場合でも「24000760」にファイル名を変更出来る方法を教えてください。
変更前のファイル名が、必ず連続した、半角英数字8文字で
変更後も
必ず連続した、半角英数字8文字（変更前と同じ数字）となるようにお願いいたします。
現状のマクロ
Sub 行政回答ファイル名変更()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim i As Long
Dim strFolderName As String
Dim arrFolderPaths As Variant
Dim strFileName As String
Dim strNewFileName As String
Dim strFullPath As String
Dim strNewFullPath As String
Const strFileHeader As String = "*ERI"
Const strParentFolderPath As String = "\\nas-sp01\share\確認部\■01_敷地照会回答書"
ReDim arrFolderPaths(0 To 0)
strFolderName = Dir(strParentFolderPath & "\*", vbDirectory)
Do Until strFolderName = ""
If Replace(strFolderName, ".", "") <> "" Then
If GetAttr(strParentFolderPath & "\" & strFolderName) And vbDirectory Then
ReDim Preserve arrFolderPaths(UBound(arrFolderPaths) + 1)
arrFolderPaths(UBound(arrFolderPaths)) = strParentFolderPath & "\" & strFolderName
End If
End If
strFolderName = Dir
Loop

For i = 1 To UBound(arrFolderPaths)
strFileName = Dir(arrFolderPaths(i) & "\*.pdf")
Do Until strFileName = ""
If StrConv(strFileName, vbNarrow) Like strFileHeader & "*" & ".pdf" Then
strNewFileName = newName(strFileName)
If strNewFileName <> "" Then
strFullPath = arrFolderPaths(i) & "\" & strFileName
strNewFullPath = arrFolderPaths(i) & "\" & strNewFileName
If FSO.FileExists(strNewFullPath) Then
Kill strFullPath
Else
Name strFullPath As strNewFullPath
End If
End If
End If
strFileName = Dir
Loop
Next
End Sub
Function newName(name_org As String) As String
Dim i As Long
For i = 1 To Len(name_org)
If Mid(name_org, i, 1) Like "[0-9]" Then
newName = Mid(name_org, i, 8) & ".pdf"
Exit Function
End If
Next
End Function
以上となります。よろしくお願いいたします。

質問者からの補足コメント

• 回答ありがとうございます。教えて頂いたコード
  Function newName(name_org As String) As String
  Dim reg As Object
  Dim matches As Object
  Set reg = CreateObject("VBScript.RegExp")
  reg.Global = True
  reg.Pattern = "[^0-9]|[0-9]{9,}"
  name_org = reg.Replace(name_org, "@")
  reg.Pattern = "[0-9]{8}"
  Set matches = reg.Execute(name_org)
  If matches.Count = 1 Then
  newName = matches.Item(0) & ".pdf"
  Else

  No.1の回答に寄せられた補足コメントです。 補足日時：2024/01/16 17:28

• 

  newName = ".pdf"
  End If
  End Function
  を設定しましたがエラー53が表示されて
  上部のコード
  Name strFullPath As strNewFullPath
  が黄色くなりエラーにてマクロが実行できませんでした。
  ご参考までにで恐縮ですが、解決方法はありますでしょうか。
  よろしくお願いいたします。

    補足日時：2024/01/16 17:31

• 8桁の数字のルールとしまして
  先頭から2文字は年度を示してます
  6月が年度変わりになりますので
  それまでは「23」となりますが
  年度が変わっても
  「23」の番号は残り
  「24と併用します
  例えば
  23012356
  24015745
  となりますのでこのルールを使って
  コードが変更できませんでしょうか？
  又　毎年マクロの「23」や「24」
  を更新しなくても良いようにできれば
  最高ですが　
  欲張り過ぎでしょうか
  申し訳ありません
  よろしくお願いします

    補足日時：2024/01/16 19:26

• 何度も回答ありがとうございます。
  ご指示の通りにコードを設定しましたら
  画像のようなエラー表示が出てしまいマクロが実行できませんでした。
  解決方法を教えて頂けますでしょうか、
  申し訳ありません、よろしくお願いいたします。

  
  No.2の回答に寄せられた補足コメントです。 補足日時：2024/01/17 11:32

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2024/01/17 10:13

また変更もあるかもなので

ごちゃごちゃ分かり難くならない様に　＃２は忘れて下さい
＃１の回答で
既存の　Function newName(name_org As String) As String
を
Function newName(ByVal name_org As String) As String
としてください
（メインプロシージャはそのままで）

この回答へのお礼

大変失礼いたしました。
先ほどの回答をよく確認しないまま
コードを設定しておりました。
先ほどの回答通りにコードを設定しますと
全て上手くできました。
ありがとうございます。
何時も最後まで教えて頂きまして、感謝いたします。
先ほど、別質問で
フォルダの削除方法を質問させえて頂きました、
以前、教えて頂いた、エラー部分をコピーするコードに変更すると上手くいきましたので
出来ればコピーした後のコピー元の不要フォルダを削除したいと思い質問させていただいております、
勝手ですが
今回も助けてください。
よろしくお願いいたします。

お礼日時：2024/01/17 13:45

No.2 回答者： Qchan1962 回答日時： 2024/01/17 10:05

メインコードをよく見ていませんでした

Sub 行政回答ファイル名変更()を下記に変更してください

Sub 行政回答ファイル名変更()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim i As Long
Dim strFolderName As String
Dim arrFolderPaths As Variant
Dim strFileName As String
Dim strNewFileName As String
Dim strFullPath As String
Dim strNewFullPath As String
Const strFileHeader As String = "*ERI"
Const strParentFolderPath As String = "\\nas-sp01\share\確認部\■01_敷地照会回答書"
ReDim arrFolderPaths(0 To 0)
strFolderName = Dir(strParentFolderPath & "\*", vbDirectory)
Do Until strFolderName = ""
If Replace(strFolderName, ".", "") <> "" Then
If GetAttr(strParentFolderPath & "\" & strFolderName) And vbDirectory Then
ReDim Preserve arrFolderPaths(UBound(arrFolderPaths) + 1)
arrFolderPaths(UBound(arrFolderPaths)) = strParentFolderPath & "\" & strFolderName
End If
End If
strFolderName = Dir
Loop

Dim strOldFileName As String '旧ファイル名用文字列型変数
For i = 1 To UBound(arrFolderPaths)
strFileName = Dir(arrFolderPaths(i) & "\*.pdf")
Do Until strFileName = ""
If StrConv(strFileName, vbNarrow) Like strFileHeader & "*" & ".pdf" Then
strOldFileName = strFileName '旧ファイル名を代入
strNewFileName = newName(strFileName)
If strNewFileName <> "" Then
strFullPath = arrFolderPaths(i) & "\" & strOldFileName '旧ファイル名でFullPathを取得
strNewFullPath = arrFolderPaths(i) & "\" & strNewFileName
If FSO.FileExists(strNewFullPath) Then
Kill strFullPath
Else
Name strFullPath As strNewFullPath
End If
End If
End If
strFileName = Dir
Loop
Next

End Sub

No.1 回答者： Qchan1962 回答日時： 2024/01/16 17:16

とりあえずの繰り返しかも知れませんが

Function newName(name_org As String) As String
の中身を

Dim reg As Object
Dim matches As Object
Set reg = CreateObject("VBScript.RegExp")
reg.Global = True
reg.Pattern = "[^0-9]|[0-9]{9,}"
name_org = reg.Replace(name_org, "@")
reg.Pattern = "[0-9]{8}"
Set matches = reg.Execute(name_org)
If matches.Count = 1 Then
newName = matches.Item(0) & ".pdf"
Else
newName = ".pdf"
End If
とかでどうかな？（間違ったら許して）

８桁数値が沢山あるとかないとかの場合
If matches.Count = 1 Then
newName = matches.Item(0) & ".pdf"
Else
newName = ".pdf"
End If
この辺を変更する必要があります