対象のフォルダの場所については共有フォルダになります。
[データ]フォルダの1つ上の階層[共有]の中に［作業フォルダ］を設けております。
「第一]「第二」フォルダに格納されているエクセルファイルのうち
”あいう”または”かきく”を含むファイルをコピーして「作業」フォルダに保存
「第一]「第二」の直下に同ファイル名は存在しません
ファイル名の頭に、「第一]、「第二」かならずついております。
では、とりあえずの叩き台として。
vba
1Sub CopyBooks()
2
3 Dim objFSO As Object 'FileSystemObject
4
5 Set objFSO = CreateObject("Scripting.FileSystemObject")
6
7 Dim strRootFolderPath As String
8
9 'ルートフォルダの絶対パス（共有フォルダのUNCパス）を代入
10 strRootFolderPath = "\\ネットワーク上のコンピューター名\共有"
11
12 'そのフォルダが存在しない場合
13 If objFSO.FolderExists(strRootFolderPath) = False Then
14 MsgBox "パス'" & strRootFolderPath & "'に該当するフォルダが見つかりません。", _
15 vbExclamation, _
16 "フォルダ参照エラー"
17 'プロシージャを抜ける
18 Exit Sub
19 End If
20
21 Dim strSourceFolderPath As String
22
23 'ルートフォルダ上におけるコピー元サブフォルダ（の最上位階層）のパスを代入
24 strSourceFolderPath = strRootFolderPath & "\データ"
25
26 'そのサブフォルダが存在しない場合
27 If objFSO.FolderExists(strSourceFolderPath) = False Then
28 MsgBox "パス'" & strSourceFolderPath & "'に該当するフォルダが見つかりません。", _
29 vbExclamation, _
30 "フォルダ参照エラー"
31 'プロシージャを抜ける
32 Exit Sub
33 End If
34
35 Dim strMonthlyFolderPath As String
36
37 '現在のシステム日時を元に月別フォルダのパスを生成
38 strMonthlyFolderPath = strSourceFolderPath & "\" & _
39 Format(Now(), "yyyy年m月")
40
41 'そのフォルダが存在しない場合
42 If objFSO.FolderExists(strMonthlyFolderPath) = False Then
43 MsgBox "パス'" & strMonthlyFolderPath & "'に該当するフォルダが見つかりません。", _
44 vbExclamation, _
45 "フォルダ参照エラー"
46 'プロシージャを抜ける
47 Exit Sub
48 End If
49
50 Dim strDestinationFolderPath As String
51
52 'ルートフォルダ上におけるコピー先サブフォルダのパスを代入
53 strDestinationFolderPath = strRootFolderPath & "\作業"
54
55 'そのサブフォルダが存在しない場合
56 If objFSO.FolderExists(strDestinationFolderPath) = False Then
57 'ルートフォルダ上にサブフォルダ[作業]を作成
58 objFSO.CreateFolder strDestinationFolderPath
59 End If
60
61'ここからデバッグ用コード
62
63 Dim wsResult As Worksheet
64 Dim lngRow As Long
65
66 '新規ブックを作成し、その 1 つめのワークシートを参照
67 Set wsResult = Workbooks.Add.Worksheets(1)
68
69 With wsResult
70 .Name = "コピー結果ログ"
71 lngRow = 1
72 .Cells(lngRow, 1).Value = "コピー順"
73 .Cells(lngRow, 2).Value = "コピー元パス"
74 .Cells(lngRow, 3).Value = "コピー先パス"
75 .Cells.EntireColumn.AutoFit
76 End With
77
78'ここまでデバッグ用コード
79
80 Dim varFolderNames As Variant
81
82 '月別フォルダ内のうち、コピー元ブックが保存されている複数のサブフォルダの名前を
83 '一次元配列（サブフォルダ名リスト）として格納する
84 varFolderNames = Array("第一", "第二")
85
86 Dim varFolderName As Variant
87 Dim strTargetFolderPath As String
88 Dim objFolder As Object 'Folder
89 Dim objFile As Object 'File
90 Dim strDestinationFilePath As String
91 Dim lngCopyCount As Long
92
93 'サブフォルダ名リスト内のアイテムを順次参照
94 For Each varFolderName In varFolderNames
95
96 '月別フォルダのパスと現在のサブフォルダ名を連結した結果
97 '（＝コピー元ブック群が保存されている 1 つのサブフォルダのパス）を代入
98 strTargetFolderPath = strMonthlyFolderPath & "\" & varFolderName
99
100 'そのフォルダが存在しない場合
101 If objFSO.FolderExists(strTargetFolderPath) = False Then
102 MsgBox "パス'" & strTargetFolderPath & "'に該当するフォルダが見つかりません。", _
103 vbExclamation, _
104 "フォルダ参照エラー"
105 'プロシージャを抜ける
106 Exit Sub
107 End If
108
109 'そのサブフォルダを Folder オブジェクトとして参照
110 Set objFolder = objFSO.GetFolder(strTargetFolderPath)
111
112 'そのフォルダ内の全てのファイルを順次参照
113 For Each objFile In objFolder.Files
114
115 'ファイル名のパターンマッチング
116 If (objFile.Name Like varFolderName & "*あいう*.xlsx") Or _
117 (objFile.Name Like varFolderName & "*かきく*.xlsx") Then
118
119 'コピー先ファイルパスを代入
120 strDestinationFilePath = strDestinationFolderPath & "\" & objFile.Name
121
122 'ファイルのコピー
123 objFile.Copy strDestinationFilePath, _
124 True
125
126 'コピーカウンタのインクリメント
127 lngCopyCount = lngCopyCount + 1
128
129'ここからデバッグ用コード
130
131 'コピー結果をワークシートに出力
132 With wsResult
133 lngRow = lngRow + 1
134 .Cells(lngRow, 1).Value = lngCopyCount
135 .Cells(lngRow, 2).Value = objFile.Path
136 .Cells(lngRow, 3).Value = strDestinationFilePath
137 .Cells.EntireColumn.AutoFit
138 End With
139
140'ここまでデバッグ用コード
141
142 End If
143 Next
144
145 Set objFolder = Nothing
146
147 Next
148
149 MsgBox "フォルダ'" & strDestinationFolderPath & "'に " & lngCopyCount & " 個のブックをコピーしました。", _
150 vbInformation, _
151 "実行完了"
152
153 Set objFSO = Nothing
154
155End Sub
変数strRootFolderPathに代入するパスは適宜書き換えて下さい。
Q&A
