teratail
回答率
85.30%
質問するログイン新規登録
トップに関する質問自動でフォルダを作成する

編集履歴

質問編集履歴

4

コードの変更

2020/07/01 03:43

投稿

ichigo15
ichigo15

スコア14

title CHANGED
File without changes
body CHANGED
@@ -51,6 +51,8 @@
51
51
 
52
52
  [フォルダパス]は取得したいフォルダのパスを入力しました。
53
53
 
54
+
55
+
54
56
  ```ここに言語名を入力
55
57
  '--- サブフォルダのパス一覧を配列に取得する ---'
56
58
  Public Sub GetAllSubFolderPath()
@@ -58,61 +60,73 @@
58
60
  '--- フォルダ一覧を取得したいフォルダのパス ---'
59
61
  Dim folderPath As String
60
62
  folderPath = "[フォルダパス]"
61
-
63
+
64
+
62
65
  '--- フォルダパスを取得する ---
63
66
  Dim folderList As Variant
64
67
  folderList = GetFolderPath(folderPath)
65
-
68
+
66
69
  End Sub
67
70
 
68
71
  '--- サブフォルダを再帰的に取得する関数 ---'
69
72
  Public Function GetFolderPath(folderPath As String) As String()
70
-
73
+
71
74
  '--- ファイルシステムオブジェクト ---'
72
75
  Dim fso As Object
73
76
  Set fso = CreateObject("Scripting.FileSystemObject")
74
-
77
+
75
78
  '--- フォルダ数を格納する変数 ---'
76
79
  Dim n As Variant
77
80
  n = fso.GetFolder(folderPath).SubFolders.Count
78
81
 
82
+ Dim r As Long
83
+ Dim c As Long
84
+ Application.ScreenUpdating = False
85
+ For r = 1 To UBound(folderList)
86
+ fs = Split(Mid(folderList(r), Len(folderPath)), "\")
87
+ For c = 1 To UBound(fs)
88
+ Cells(r, c + 1).Value = fs(c)
89
+ Next
90
+ Next
91
+ Application.ScreenUpdating = True
92
+
79
93
  If (0 < n) Then
80
94
  '--- フォルダパスを格納する配列 ---'
81
95
  Dim str() As String
82
96
  ReDim str(1 To n)
83
-
97
+
84
98
  '--- フォルダパスを格納 ---'
85
99
  Dim i As Long
86
100
  Dim j As Long
87
101
  Dim m As Long
88
102
  i = 1
89
103
  Dim strTmp() As String
90
-
104
+
91
105
  'フォルダパスを指定してすべてのサブフォルダを取得
92
106
  Dim f As Object
93
107
  For Each f In fso.GetFolder(folderPath).SubFolders
94
108
  str(i) = f.Path
95
-
109
+
96
110
  strTmp = GetFolderPath(str(i)) '再帰的呼び出し
97
111
  If (Not IsEmptyArray(strTmp)) Then
98
112
  m = UBound(strTmp, 1)
99
113
  Else
100
114
  m = 0
101
115
  End If
102
-
116
+
103
117
  'サブフォルダ内にさらにフォルダがあればその分だけ配列を拡張
104
118
  n = UBound(str, 1)
105
119
  ReDim Preserve str(1 To n + m)
106
120
  For j = 1 To m
107
121
  str(i + j) = strTmp(j)
108
122
  Next j
109
-
123
+
110
124
  i = i + m + 1
111
125
  Next f
112
126
  End If
113
-
127
+
114
128
  GetFolderPath = str
115
-
129
+
116
130
  End Function
117
131
 
118
132
  '--- 配列が空かどうかを判定する関数 ---'
@@ -122,12 +136,14 @@
122
136
  If (0 < UBound(arrayTmp, 1)) Then
123
137
  IsEmptyArray = False
124
138
  End If
125
-
139
+
126
140
  Exit Function
127
141
 
128
142
  ERROR_:
129
-
143
+
130
144
  IsEmptyArray = True
131
-
145
+
132
146
  End Function
147
+
148
+
133
149
  ```

3

困っていることの変更

2020/07/01 03:43

投稿

ichigo15
ichigo15

スコア14

title CHANGED
File without changes
body CHANGED
@@ -33,47 +33,101 @@
33
33
 
34
34
  (困っていること）
35
35
 
36
- （1）と（2）は問題ありません
37
- （3）～（5）が困っております。
36
+ （3）です。
38
37
 
39
- （3）はパスの一覧は作れると思いますが、フォルダだけの一覧を作成することができません
38
+ 　http://www.fingeneersblog.com/1610/
39
+ 　　↑
40
- （5）は似たようなものを参照して作成することができたのですが下層部のフォルダの作成が
40
+ 　こちらのサイトを参照させていただいたのですが何もおこりません
41
- 　　　できません
42
- 　　　例でいうと、テスト1の中にテスト2～4の作成はできました
41
+ 　どうやったらフォルダの一覧を取得できるようになるのでしょうか？
43
- 　　　テスト5～7の作成がわかりません
44
- 　
45
- ご指導頂けますでしょうか。
46
- 宜しくお願いいたします
47
42
 
43
+ 　B列に1次フォルダ、C列に2次フォルダ、D列に3次フォルダ・・・・
44
+ 　入力箇所はB13からで、階層フォルダは次の行に入力できるようになりたいです。
45
+
46
+
47
+ 　ご指導頂けますでしょうか。
48
+ 　宜しくお願いいたします
49
+
48
50
  ### 該当のソースコード
49
51
 
50
- フォルダを作成するコードです
51
- A6にフォルダのパス、B6～にフォルダ名としています
52
+ [フォルダパス]は取得したいフォルダのパスを入力しました。
52
- できれば作成先を探して指定するようにしたいと思っております。
53
53
 
54
54
  ```ここに言語名を入力
55
+ '--- サブフォルダのパス一覧を配列に取得する ---'
55
- Sub フォルダ作成()
56
+ Public Sub GetAllSubFolderPath()
57
+
56
-
58
+ '--- フォルダ一覧を取得したいフォルダのパス ---'
57
- Dim Path As String
59
+ Dim folderPath As String
58
- Path = Range("A6").Value
60
+ folderPath = "[フォルダパス]"
59
61
 
62
+ '--- フォルダパスを取得する ---
60
- Dim i As Long
63
+ Dim folderList As Variant
61
- For i = 6 To Range("B6").End(xlDown).Row
64
+ folderList = GetFolderPath(folderPath)
62
65
 
66
+ End Sub
67
+
68
+ '--- サブフォルダを再帰的に取得する関数 ---'
69
+ Public Function GetFolderPath(folderPath As String) As String()
70
+
71
+ '--- ファイルシステムオブジェクト ---'
72
+ Dim fso As Object
73
+ Set fso = CreateObject("Scripting.FileSystemObject")
74
+
75
+ '--- フォルダ数を格納する変数 ---'
76
+ Dim n As Variant
77
+ n = fso.GetFolder(folderPath).SubFolders.Count
78
+
79
+ If (0 < n) Then
80
+ '--- フォルダパスを格納する配列 ---'
63
- Dim FolderName As String
81
+ Dim str() As String
64
- FolderName = Cells(i, 2).Value
82
+ ReDim str(1 To n)
65
83
 
84
+ '--- フォルダパスを格納 ---'
85
+ Dim i As Long
86
+ Dim j As Long
87
+ Dim m As Long
88
+ i = 1
66
- Dim NewDirPath As String
89
+ Dim strTmp() As String
67
- NewDirPath = Path & "\" & FolderName
68
90
 
69
-
70
- If Dir(NewDirPath, vbDirectory) = "" Then
91
+ 'フォルダパスを指定してすべてのサブフォルダを取得
92
+ Dim f As Object
71
- MkDir Path & "\" & FolderName
93
+ For Each f In fso.GetFolder(folderPath).SubFolders
94
+ str(i) = f.Path
95
+
96
+ strTmp = GetFolderPath(str(i)) '再帰的呼び出し
97
+ If (Not IsEmptyArray(strTmp)) Then
98
+ m = UBound(strTmp, 1)
99
+ Else
100
+ m = 0
72
- End If
101
+ End If
102
+
103
+ 'サブフォルダ内にさらにフォルダがあればその分だけ配列を拡張
104
+ n = UBound(str, 1)
105
+ ReDim Preserve str(1 To n + m)
106
+ For j = 1 To m
107
+ str(i + j) = strTmp(j)
108
+ Next j
109
+
110
+ i = i + m + 1
111
+ Next f
112
+ End If
73
113
 
74
- Next i
114
+ GetFolderPath = str
75
115
 
116
+ End Function
117
+
118
+ '--- 配列が空かどうかを判定する関数 ---'
119
+ Public Function IsEmptyArray(arrayTmp As Variant) As Boolean
76
- MsgBox "終了しました。"
120
+ On Error GoTo ERROR_
121
+
77
-
122
+ If (0 < UBound(arrayTmp, 1)) Then
123
+ IsEmptyArray = False
78
- End Sub
124
+ End If
125
+
126
+ Exit Function
127
+
128
+ ERROR_:
129
+
130
+ IsEmptyArray = True
131
+
132
+ End Function
79
133
  ```

2

コードや内容を変更

2020/06/19 03:50

投稿

ichigo15
ichigo15

スコア14

title CHANGED
File without changes
body CHANGED
@@ -3,16 +3,15 @@
3
3
  あるフォルダの中に入っているフォルダ（下層部まで）を全て指定のフォルダ内に作成したいです
4
4
  フォルダの作成場所はPC内だけでなく、サーバー上も想定しております
5
5
 
6
-
7
-
8
6
  （例）
9
7
 
10
8
  　テスト1　　⇒　テスト2　　⇒ テスト5　　⇒ テスト7
11
- 　　　　　　　　　　　　　　　　 テスト6
12
9
 
10
+ テスト1　　⇒　テスト2　　⇒ テスト6
13
11
 
14
- 　　　　　　　　 テスト3
12
+ テスト1　　⇒ テスト3
13
+ 　
15
- 　　　　　　　　 テスト4
14
+ テスト1　　⇒ テスト4
16
15
 
17
16
 
18
17
  C:\Users\〇〇〇\Documents\テスト1\テスト2
@@ -21,98 +20,60 @@
21
20
  C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5
22
21
  C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト6
23
22
  C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5\テスト7
24
- 　　　　　　
25
23
 
24
+ イメージは、下記のとおりです。　　　　　　
25
+ （1）フォルダを選ぶ
26
+ （2）（1）のパスをExcelに表示
27
+ （3）（1）のフォルダ一覧をExcelに作成
28
+ （4）フォルダを選ぶ
29
+ （5）（4）のフォルダに（3）のフォルダを作成
30
+
31
+
26
32
  ### 発生している問題・エラーメッセージ
27
33
 
28
- ファイルの整理にファイルリストをマクロで作成しています
29
- 同じようにファルダのリストを作成して
34
+ (困っていること）
30
- もしくは、ファルダのパスからフォルダを作成できないかと
31
- 思っておりますが何をどうしてよいのか分かりません
32
35
 
33
- ①フォルダを指定
36
+ （1）と（2）は問題ありません
34
- ②フォルダ内のフォルダをリスト化
37
+ （3）～（5）が困っております。
35
- ③指定の箇所にリストのフォルダを作成
36
38
 
39
+ （3）はパスの一覧は作れると思いますが、フォルダだけの一覧を作成することができません
40
+ （5）は似たようなものを参照して作成することができたのですが下層部のフォルダの作成が
41
+ 　　　できません
42
+ 　　　例でいうと、テスト1の中にテスト2～4の作成はできました
43
+ 　　　テスト5～7の作成がわかりません
44
+ 　
37
45
  ご指導頂けますでしょうか。
38
46
  宜しくお願いいたします
39
47
 
40
48
  ### 該当のソースコード
41
49
 
42
- ファイルのリストを作成しているマクロです。
50
+ フォルダを作成するコードです
51
+ A6にフォルダのパス、B6～にフォルダ名としています
43
- 全然関係ないようでしたら申し訳ございません。
52
+ できれば作成先を探して指定するようにしたいと思っております。
44
53
 
45
54
  ```ここに言語名を入力
46
- Sub getFileList()
55
+ Sub フォルダ作成()
47
-
48
- Dim start_x As Long: start_x = X
56
+
49
- Dim start_y As Long: start_y = Y
50
- Dim maxRow, maxCol
51
- Dim searchFolderPath As String
57
+ Dim Path As String
52
- Dim checkFolderPath
58
+ Path = Range("A6").Value
53
59
 
54
- Application.ScreenUpdating = False
55
- On Error Resume Next
60
+ Dim i As Long
61
+ For i = 6 To Range("B6").End(xlDown).Row
56
62
 
63
+ Dim FolderName As String
64
+ FolderName = Cells(i, 2).Value
65
+
66
+ Dim NewDirPath As String
67
+ NewDirPath = Path & "\" & FolderName
68
+
69
+
57
- searchFolderPath = Worksheets(FOLDERPATH).Range("B3").Value
70
+ If Dir(NewDirPath, vbDirectory) = "" Then
71
+ MkDir Path & "\" & FolderName
72
+ End If
58
73
 
59
- ' ファイルの存在チェック
74
+ Next i
60
- checkFolderPath = Dir(searchFolderPath, vbDirectory)
61
75
 
62
- If searchFolderPath = "" Or checkFolderPath = "" Then
63
- MsgBox ERRORMESSAGE, vbCritical
76
+ MsgBox "終了しました。"
64
- End
77
+
65
- End If
66
-
67
- ' シートの初期化
68
- maxRow = Worksheets(FOLDERPATH).Cells(Rows.Count, X).End(xlUp).Row
69
- maxCol = Worksheets(FOLDERPATH).Cells(Y, Columns.Count).End(xlToLeft).Column
70
- Worksheets(FOLDERPATH).Range(Cells(Y, X), Cells(maxRow + Y, maxCol + X)).ClearContents
71
-
72
- '　ファイル一覧作成
73
- Call printFileList(searchFolderPath, start_x, start_y)
74
-
75
- ' フォーマット整形
76
- Columns("B:F").Select
77
- Columns("B:F").EntireColumn.AutoFit
78
- Range("A1").Select
79
-
80
- Application.ScreenUpdating = True
81
-
82
78
  End Sub
83
- ```
79
+ ```
84
- ```ここに言語を入力
85
- Private Sub printFileList(searchFolderPath As String, ByRef start_x, ByRef start_y)
86
-
87
- Dim fso As New FileSystemObject
88
- Dim folderList As Folders
89
- Dim folderName As folder
90
- Dim fileName As File
91
-
92
- Dim str As String
93
- Dim slashNum As Long
94
-
95
- Set folderList = fso.GetFolder(searchFolderPath).SubFolders
96
-
97
- 'フォルダ内のファイル名の取得
98
- For Each fileName In fso.GetFolder(searchFolderPath).Files
99
- slashNum = InStrRev(fileName.Path, "\")
100
- 'セルにパスとファイル名を書き込む
101
- Worksheets(FOLDERPATH).Cells(start_y, start_x).Value = Mid(fileName.Path, slashNum + 1)
102
- Worksheets(FOLDERPATH).Cells(start_y, start_x + 1).Value = Left(fileName.Path, slashNum - 1)
103
- Worksheets(FOLDERPATH).Cells(start_y, start_x + 2).Value = Format(fileName.Size / 1024, "0.#0") & " バイト"
104
- Worksheets(FOLDERPATH).Cells(start_y, start_x + 3).Value = fileName.DateCreated
105
- Worksheets(FOLDERPATH).Cells(start_y, start_x + 4).Value = fileName.DateLastModified
106
- start_y = start_y + 1
107
- Next
108
-
109
- ' サブフォルダ一覧取得　再帰処理
110
- For Each folderName In folderList
111
- Call printFileList(folderName.Path, start_x, start_y)
112
- Next
113
-
114
- End Sub
115
-
116
- ```
117
-
118
- 。

1

問題点の変更

2020/06/18 04:01

投稿

ichigo15
ichigo15

スコア14

title CHANGED
File without changes
body CHANGED
@@ -1,18 +1,47 @@
1
1
  ### 前提・実現したいこと
2
2
 
3
3
  あるフォルダの中に入っているフォルダ（下層部まで）を全て指定のフォルダ内に作成したいです
4
+ フォルダの作成場所はPC内だけでなく、サーバー上も想定しております
4
5
 
6
+
7
+
8
+ （例）
9
+
10
+ 　テスト1　　⇒　テスト2　　⇒ テスト5　　⇒ テスト7
11
+ 　　　　　　　　　　　　　　　　 テスト6
12
+
13
+
14
+ 　　　　　　　　 テスト3
15
+ 　　　　　　　　 テスト4
16
+
17
+
18
+ C:\Users\〇〇〇\Documents\テスト1\テスト2
19
+ C:\Users\〇〇〇\Documents\テスト1\テスト3
20
+ C:\Users\〇〇〇\Documents\テスト1\テスト4
21
+ C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5
22
+ C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト6
23
+ C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5\テスト7
24
+ 　　　　　　
25
+
5
26
  ### 発生している問題・エラーメッセージ
6
27
 
7
- ファイルリストを作成しているマクロでパスも取得しています
28
+ ファイルの整理にファイルリストをマクロで作成しています
29
+ 同じようにファルダのリストを作成して
8
- このパスから作成することができればと思っていますが
30
+ もしくは、ファルダのパスからフォルダを作成できないかと
9
- どこから手を付けてよいか分かりません
31
+ 思っておりますが何をどうしてよいのか分かりません
10
32
 
33
+ ①フォルダを指定
34
+ ②フォルダ内のフォルダをリスト化
35
+ ③指定の箇所にリストのフォルダを作成
36
+
11
37
  ご指導頂けますでしょうか。
12
38
  宜しくお願いいたします
13
39
 
14
40
  ### 該当のソースコード
15
41
 
42
+ ファイルのリストを作成しているマクロです。
43
+ 全然関係ないようでしたら申し訳ございません。
44
+
16
45
  ```ここに言語名を入力
17
46
  Sub getFileList()
18
47