Excelデータ連携によるファイル名変更

実現したいこと

・子フォルダ内pdfファイル名を格納先親フォルダ名をキーにして、Excel（変換DB.xlsx）から情報取得しファイル名を変更するツールを作成したいです。
補足1：コードの流れは、パターン1、パターン2、パターン3を網羅したものを考えています。
※先日teratailにて質問した内容に対してやりたい事は変えず、一部方法を変更をしました。
URL https://teratail.com/questions/7t3o5dc7dz97ij
変更内容：Accessクエリから情報取得する部分を、Excel（変換DB.xlsx）から情報取得という形にしました。
●処理イメージ図

●処理前

●処理後

前提

・Excel（変換DB.xlsx）
共通キー：親フォルダ名（フォルダ名）＝社外購買番号（変換DB.xlsx）
共通キーからファイル名変更の情報を取得し、pdfファイル名を変更
・変換DB.xlsxの項目は、1つの社外購買番号に対して1つのファイル名変更のみ存在する条件になります。
画像では、C0001までですが、データは、D0001..等増えていく形になります。
桁数はすべて同じになります。
●変換DB.xlsx

●フォルダ構成

●ツール一覧フォルダ構成

ツールのコード流れ※処理イメージの詳細

＜パターン1＞
①.子フォルダ内のファイル件数取得

②.1つめファイルは親フォルダ名称をキーにして、変換DB.xlsxから該当ファイル名変更情報を取得
例.親フォルダ名：A0001なので、変換DBのA2からセル入力最終行間の同一セル（A0001）を照合しB列(202301-00010_A0001_株式会社山田)を取得

③.ファイル名を取得情報名に変更
例.202301-00010_A0001_株式会社山田.pdfとなる。

④.1つめファイルの為、ファイル名語尾に_00を追加し、ファイル名変更
例.202301-00010_A0001_株式会社山田_00.pdf

⑤.2つめファイルは、パターン1の上記②～④を繰り返す。2番目なのでファイル名語尾は_01となる
例.202301-00010_A0001_株式会社山田_01.pdf

＜パターン2＞
①.子フォルダ内のファイル名件数取得

②.1つめのファイル名に対して親フォルダ名が入るので、ファイル名変更無
例.B0001が入っている為、202302-00010_B0001_株式会社田中_00.pdfは変更しない。

③.2つめのファイル名に対して親フォルダ名が入らないので、パターン1の②～③の処理を行う。
例.202302-00010_B0001_株式会社田中.pdfとなる。

④.2つめファイルは、2番目なのでファイル名語尾は_01となる。
1つめのファイルに親フォルダ名がのっているため語尾名は、2つめという事で_01となる。
例.202302-00010_B0001_株式会社田中_01.pdf

＜パターン3＞
処理はパターン1、2と同じ。
変換DB.xlsxのファイル名変更情報の文字数がパターン1、2と違うという意味でのせました。

＜その他＞
・語尾のファイル名は、_00,_01,_02..._20でなくても、_0,_1,_2..._20でも問題ありません。

発生している問題・出来なかった事

1.Excel（変換DB.xlsx）から取得した情報とフォルダ名を照合し、ファイル名変更のやり方が全く分かりませんでした。
2.1の後から、条件にそったファイル名を変更する方法が全く分かりませんでした。

該当のソースコード

VBA
1Sub ファイル名変更()
2Const TargetFld As String = "C:\Users\○○○\Desktop\一時\テスト環境" 'フォルダ作成上位場所
3Const Copy = "C:\Users\z09071\Desktop\一時\ツール一覧" '変換DB.xlsx保管パス
4Const Cn As String = "変換DB.xlsx"
5Dim objFso As Object
6Dim objfld As Object
7Dim strFolderPath As String
8Dim swb As Workbook '変換DBファイル変数
9Dim sws As Worksheet '変換DBファイルシート変数
10Dim smaxrow As Long '変換DB最終行
11Dim a As Long '変換DB繰返し回数
12Dim sresult As String '変換DB社外購買番号
13
14Set objFso = CreateObject("Scripting.FileSystemObject")
15Set swb = Workbooks.Open(Copy & "\" & Cn) '変換DB.xlsxファイルを開く
16Set sws = swb.Worksheets("変換DB")
17smaxrow = sws.Cells(Rows.Count, "A").End(xlUp).Row '変換DBA列最終行
18For a = 2 To smaxrow '親フォルダ名と変換DB社外購買番号照合
19    
20
21End If
22
23
24For Each objfld In Object.GetFolder(Target.Path & "\完了").SubFolders '親フォルダ内の完了フォルダ毎処理
25    
26    
27Next
28
29
30End Sub
31

試したこと

AccessからExcel（変換DB.xlsx）への転記はできたのですが、Excelから各ファイルに対してのファイル名変更ができませんでした。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

tatsu99

2023/04/26 11:28

＜パターン２＞の例で 202302-00010_B0001_株式会社田中_00.pdf　と sample2.pdf が完了フォルダに格納されているが、もし 202302-00010_B0001_株式会社田中_01.pdf　と sample2.pdf が格納されていたら、 sample2.pdf は、どのような名称にするのですか。 202302-00010_B0001_株式会社田中_xx.pdf　のxxはいくつにするかという質問です。

tatsu99

2023/04/26 11:31

追加質問です。＜パターン２＞例で 202302-00010_B0001_株式会社田中_00.pdf　と sample2.pdf が完了フォルダに格納されているが、もし 202301-ZZZZZ_B0001_株式会社田中_01.pdf　と sample2.pdf が格納されていても sample2.pdf は、以下の名称で良いですか。 202302-00010_B0001_株式会社田中_01.pdf

jabe

2023/04/27 02:35

返信ありがとうございます。回答させていただきます。ケース① 202302-00010_B0001_株式会社田中_01.pdf　と sample2.pdfのケースの場合、以下どちらかの処理が出来れば問題ありません。 ①-1.202302-00010_B0001_株式会社田中_02.pdf ※存在しているpdfの語尾名が一番高い名前を起点にカウントアップしたいと考えています。 ①-2.エラーで停止ケース② 202301-ZZZZZ_B0001_株式会社田中_01.pdf　と sample2.pdfのケースの場合、以下どちらかの処理が出来れば問題ありません。 ②-1.仰る通りの202302-00010_B0001_株式会社田中_01.pdfで問題ありません。 ②-2.エラー停止

tatsu99

2023/04/27 08:48

ファイル名のチェックですが、以下のようになりますがよろしいでしょうか。１．ファイル名の中に、親フォルダ名が含まれない場合は、無条件にOKとし、ファイル名変更の対象となる。２．ファイル名の中に、親フォルダ名が含まれる場合、 ①ファイル名は　変換DB.xlsxのB列（ファイル名変更）+"_"+連番+".pdf"　であること。　連番は00～99の何れかの数字であること ②上記①の条件を満たさない場合は、エラー表示して処理を打ち切る。ファイルのリネームは以下のようになります。ファイルのリネームは、完了フォルダ内の最も大きい連番の次の値から割り当てを開始する。連番を持つファイルが存在しない場合は、00から開始する。連番が、99を超える場合、エラー表示して、処理を打ち切る。

jabe

2023/04/27 09:25

返信と対応ありがとうございます。はい、tatsu99さんの上記内容で問題ありません。お手数掛けますが、よろしくお願いします。

行動規範の内容に同意します

回答1件

ベストアンサー

注意事項
Const FolderA As String = "D:\goo\data7" 'テスト環境フォルダ
は、テスト環境フォルダ名です。あなたの環境に合わせて変えてください。
変換DB.xlsxはマクロのあるブックと同じフォルダに格納されている前提です。
変換DB.xlsxのシート名はSheet1としました。異なる場合は、適切に変更してください。
その場合、 Set ws = wb.Worksheets("Sheet1")　を変えてください。

VBA
1Option Explicit
2Public Sub ファイル名変更()
3    Const FolderA As String = "D:\goo\data7"    'テスト環境フォルダ
4    Dim wb As Workbook
5    Dim ws As Worksheet
6    Dim dicT As Object      '連想配列　キー：社外購買番号　値：ファイル名変更
7    Dim maxrow As Long
8    Dim wrow As Long
9    Dim key As String
10    Dim fname As String
11    Dim FSO As Object
12    Dim Folder As Object
13    '変換DB.xlsx読み込み
14    Set wb = Workbooks.Open(ThisWorkbook.path & "\" & "変換DB.xlsx")
15    Set ws = wb.Worksheets("Sheet1")
16    Set dicT = CreateObject("Scripting.Dictionary")
17    maxrow = ws.Cells(Rows.count, 1).End(xlUp).Row             '1列目の最終行を求める
18    '社外購買番号及びファイル名変更を取り込む
19    For wrow = 2 To maxrow
20        key = ws.Cells(wrow, 1).Value
21        fname = ws.Cells(wrow, 2).Value
22        If key <> "" And InStr(fname, key) > 0 Then
23            dicT(LCase(key)) = fname
24        Else
25            MsgBox ("社外購買番号[" & key & "]がファイル名変更[" & fname & "]にありません")
26            ws.Activate
27            ws.Cells(wrow, 1).Select
28            Exit Sub
29        End If
30    Next
31    wb.Close
32    'テスト環境フォルダ読み込み
33    Set FSO = CreateObject("Scripting.FileSystemObject")
34    '各親フォルダを処理する
35    For Each Folder In FSO.getfolder(FolderA).subfolders
36        key = LCase(Folder.name)
37        If dicT.exists(key) = True Then
38            '親フォルダが変換DB.xlsxの社外購買番号に登録されていれば処理する
39            Dim child_folder_path As String
40            child_folder_path = Folder.path & "\" & "完了"
41            If FSO.folderexists(child_folder_path) = False Then
42                MsgBox (child_folder_path & "が存在しません")
43                Exit Sub
44            End If
45            '当該完了フォルダ内のファイルをリネームする。エラーがあれば処理を終了
46            If change_name(dicT, key, child_folder_path) = False Then
47                Exit Sub
48            End If
49        End If
50    Next
51    MsgBox ("完了")
52End Sub
53'ファイル名変更
54Private Function change_name(dicT As Object, ByVal key As String, ByVal child_folder_path) As Boolean
55    change_name = False
56    Dim fname As String
57    Dim lfname As String
58    Dim maxno As Long: maxno = -1   '最大通番
59    Dim pdf_files() As String
60    Dim fcount As Long: fcount = 0
61    Dim reg As Object
62    Dim i As Long
63    Set reg = CreateObject("VBScript.RegExp")
64    reg.Pattern = "^_\d\d\.pdf$"
65    
66    fname = Dir(child_folder_path & "\*.pdf", vbNormal)
67    '全てのpdfファイルを取得する
68    Do While fname <> ""
69        lfname = LCase(fname)
70        If InStr(lfname, key) > 0 Then
71            '親フォルダ名がファイル名に含まれる場合
72            Dim bname_len As Long
73            bname_len = Len(dicT(key))
74            If bname_len + 7 <> Len(lfname) Then
75                MsgBox (fname & "のファイル名不正(1)")
76                Exit Function
77            End If
78            If Left(lfname, bname_len) <> LCase(dicT(key)) Then
79                MsgBox (fname & "のファイル名不正(2)")
80                Exit Function
81            End If
82            Dim ext As String
83            ext = Right(lfname, 7)
84            If reg.test(ext) = False Then
85                MsgBox (fname & "のファイル名不正(3)")
86                Exit Function
87            End If
88            'ファイル名中の通番を取得し、最大通番より大きいなら置き換える
89            Dim no As Long
90            no = CLng(Mid(ext, 2, 2))
91            If no > maxno Then maxno = no
92        Else
93            '親フォルダ名がファイル名に含まれない場合
94            ReDim Preserve pdf_files(fcount)
95            pdf_files(fcount) = fname
96            fcount = fcount + 1
97        End If
98        fname = Dir()
99    Loop
100    'リネーム処理
101    For i = 0 To fcount - 1
102        maxno = maxno + 1
103        If maxno > 99 Then
104            MsgBox ("ファイル名の通番が99を超えました")
105            Exit Function
106        End If
107        Dim from_name As String
108        Dim to_name As String
109        from_name = child_folder_path & "\" & pdf_files(i)
110        to_name = child_folder_path & "\" & dicT(key) & "_" & Format(maxno, "00") & ".pdf"
111        'ファイル名変更
112        Name from_name As to_name
113    Next
114    change_name = True
115End Function
116

投稿2023/04/27 09:39

tatsu99

総合スコア5438

jabe

2023/04/28 00:36

迅速な対応ありがとうございます。思い通り動作する事が出来ました。感動しました。中身を1つずつ読み解いていきたいと考えていますので、また質問するかもしれませんがよろしくお願いします。

jabe

2023/04/28 09:10

64行目のreg.Pattern = "^_\d\d\.pdf$"の意味を教えてください。

tatsu99

2023/04/28 09:55

reg.Pattern = "^_\d\d\.pdf$"　ですが正規表現です。詳しくは、下記等を参照してください。 http://officetanaka.net/excel/vba/tips/tips38.htm ファイル名の末尾の７文字のチェックを行っています。末尾の７文字が、_NN.pdf　（Nは0～9の１文字）かどうかのチェックを行います。 ^・・先頭 \d・・0～9の１文字 .は任意の１文字だが、.そのものなので\.と記述 $・・最後を意味します。日本語で表現すると先頭が_で始まり、数字が２文字続き、.pdfで終わる文字列となります。

jabe

2023/05/08 01:33

返信が遅くなり申し訳ありません。解説ありがとうございます。ファイル名を任意の文字をチェックできる機能があるんですね。リンク先を読み解いてみます。

行動規範の内容に同意します