下記のマクロは以前教えて頂いたマクロで
マクロを実行すると
指定フォルダ内のサブフォルダ「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
以上となります。よろしくお願いいたします。
No.3ベストアンサー
- 回答日時:
また変更もあるかもなので
ごちゃごちゃ分かり難くならない様に #2は忘れて下さい
#1の回答で
既存の Function newName(name_org As String) As String
を
Function newName(ByVal name_org As String) As String
としてください
(メインプロシージャはそのままで)
大変失礼いたしました。
先ほどの回答をよく確認しないまま
コードを設定しておりました。
先ほどの回答通りにコードを設定しますと
全て上手くできました。
ありがとうございます。
何時も最後まで教えて頂きまして、感謝いたします。
先ほど、別質問で
フォルダの削除方法を質問させえて頂きました、
以前、教えて頂いた、エラー部分をコピーするコードに変更すると上手くいきましたので
出来ればコピーした後のコピー元の不要フォルダを削除したいと思い質問させていただいております、
勝手ですが
今回も助けてください。
よろしくお願いいたします。
No.2
- 回答日時:
メインコードをよく見ていませんでした
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
- 回答日時:
とりあえずの繰り返しかも知れませんが
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
とかでどうかな?(間違ったら許して)
8桁数値が沢山あるとかないとかの場合
If matches.Count = 1 Then
newName = matches.Item(0) & ".pdf"
Else
newName = ".pdf"
End If
この辺を変更する必要があります
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2024/01/12 16:09
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/07/03 09:11
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/11/09 11:51
- Visual Basic(VBA) エクセルのマクロについて教えてください。 7 2023/07/04 09:18
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/15 15:12
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/07/01 12:54
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/11/08 10:31
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/02/22 08:53
- Excel(エクセル) マクロのコードを、少しでも削って短くしたい 3 2022/08/30 07:46
このQ&Aを見た人はこんなQ&Aも見ています
-
賃貸で可能な古民家風レトロな部屋作りのコツ!改めて知る畳の高い機能性と魅力も紹介
畳の部屋を雰囲気のよい部屋に仕上げたい!賃貸住宅でもできる古民家風のレトロな部屋作りのコツを伺った。
-
Cellsのコードが打てません
Visual Basic(VBA)
-
VBA実行後に元のセルに戻りたい
Visual Basic(VBA)
-
Excel VBAでの数値の計算についておしえてください
Visual Basic(VBA)
-
-
4
ExcelのVBAのことで質問です。 以下のコードを入れ、ボタンを押せば作動させると写真のように画面
Visual Basic(VBA)
-
5
excelのVBAについて、以下のコードに追加をお願いいたします。
Visual Basic(VBA)
-
6
エクセルのマクロについて教えてください。
Visual Basic(VBA)
-
7
エクセルのマクロについて教えてください。
Visual Basic(VBA)
-
8
VBEを開くのにコマンド名が「Visual Basic」な理由はなぜ?
Visual Basic(VBA)
-
9
ExcelのVBAコードを教えて頂けますでしょうか。 例シート2つがあります。 シート1は元データ
Visual Basic(VBA)
-
10
VBA 二つのブックをうまく扱えないでいます
Visual Basic(VBA)
-
11
Excel VBA ダブルクリックで入力 複数まとめる
Visual Basic(VBA)
-
12
VBA コード
Visual Basic(VBA)
-
13
VBAのことで質問です
Visual Basic(VBA)
-
14
Excelセルに入力された文字の色を変える方法を教えてください
Visual Basic(VBA)
-
15
excelのVBAで画像の動作をさせるため、プログラムを教えてください。
Visual Basic(VBA)
-
16
マクロについて教えてください。 下記のマクロは以前教えて頂いたマクロです。 マクロを実行すると 指定
Visual Basic(VBA)
-
17
エクセルのマクロ
Excel(エクセル)
-
18
エクセルVBAでデータ転記
Visual Basic(VBA)
-
19
VBAのコードを教えてください
Visual Basic(VBA)
-
20
Excel マクロについて
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excel・Word リサーチ機能を無...
-
特定のPCだけ動作しないVBAマク...
-
Excel マクロ VBA プロシー...
-
エクセルで特定の列が0表示の場...
-
メッセージボックスのOKボタ...
-
一つのTeratermのマクロで複数...
-
ExcelVBAでPDFを閉じるソース
-
ソース内の行末に\\
-
特定文字のある行の前に空白行...
-
TERA TERMを隠す方法
-
wordを起動した際に特定のペー...
-
アクセス マクロ クリップボ...
-
【EXCEL VBA】オートシェイプを...
-
ExcelVBA 図形をクリックした...
-
ExcelのVBA。public変数の値が...
-
エクセルに張り付けた写真のフ...
-
マクロ実行時、ユーザーフォー...
-
コマンドボタンに二回目のマク...
-
WORD テキストボックスを全ペ...
-
EXCELマクロでのThisisWor...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel・Word リサーチ機能を無...
-
エクセルで特定の列が0表示の場...
-
特定のPCだけ動作しないVBAマク...
-
Excel マクロ VBA プロシー...
-
メッセージボックスのOKボタ...
-
一つのTeratermのマクロで複数...
-
ExcelのVBA。public変数の値が...
-
Excel VBAからAccessマクロを実...
-
EXCELのVBAでRange("A1:C4")を...
-
ExcelVBAでPDFを閉じるソース
-
エクセルに張り付けた写真のフ...
-
エクセルで別のセルにあるふり...
-
TERA TERMを隠す方法
-
2つのマクロでチェックボックス...
-
マクロ実行時、ユーザーフォー...
-
【マクロ】1つのマクロの中に...
-
ピボットテーブルでの毎回可変...
-
特定文字のある行の前に空白行...
-
エクセルのマクロについて教え...
-
wordを起動した際に特定のペー...
おすすめ情報
回答ありがとうございます。教えて頂いたコード
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
End Function
を設定しましたがエラー53が表示されて
上部のコード
Name strFullPath As strNewFullPath
が黄色くなりエラーにてマクロが実行できませんでした。
ご参考までにで恐縮ですが、解決方法はありますでしょうか。
よろしくお願いいたします。
8桁の数字のルールとしまして
先頭から2文字は年度を示してます
6月が年度変わりになりますので
それまでは「23」となりますが
年度が変わっても
「23」の番号は残り
「24と併用します
例えば
23012356
24015745
となりますのでこのルールを使って
コードが変更できませんでしょうか?
又 毎年マクロの「23」や「24」
を更新しなくても良いようにできれば
最高ですが
欲張り過ぎでしょうか
申し訳ありません
よろしくお願いします
何度も回答ありがとうございます。
ご指示の通りにコードを設定しましたら
画像のようなエラー表示が出てしまいマクロが実行できませんでした。
解決方法を教えて頂けますでしょうか、
申し訳ありません、よろしくお願いいたします。