編集履歴

質問編集履歴

コードの変更

2020/07/01 03:43

投稿

ichigo15

スコア14

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -104,6 +104,10 @@
 ```ここに言語名を入力
 '--- サブフォルダのパス一覧を配列に取得する ---'
@@ -118,41 +122,65 @@
     folderPath = "[フォルダパス]"
+    '--- フォルダパスを取得する ---
+    Dim folderList As Variant
+    folderList = GetFolderPath(folderPath)
+End Sub
+'--- サブフォルダを再帰的に取得する関数 ---'
+Public Function GetFolderPath(folderPath As String) As String()
+    '--- ファイルシステムオブジェクト ---'
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    '--- フォルダ数を格納する変数 ---'
+    Dim n As Variant
+    n = fso.GetFolder(folderPath).SubFolders.Count
-    '--- フォルダパスを取得する ---
-    Dim folderList As Variant
-    folderList = GetFolderPath(folderPath)
-End Sub
-'--- サブフォルダを再帰的に取得する関数 ---'
-Public Function GetFolderPath(folderPath As String) As String()
-    '--- ファイルシステムオブジェクト ---'
-    Dim fso As Object
-    Set fso = CreateObject("Scripting.FileSystemObject")
-    '--- フォルダ数を格納する変数 ---'
-    Dim n As Variant
+    Dim r As Long
+    Dim c As Long
+    Application.ScreenUpdating = False
+    For r = 1 To UBound(folderList)
-    n = fso.GetFolder(folderPath).SubFolders.Count
+    fs = Split(Mid(folderList(r), Len(folderPath)), "\")
+    For c = 1 To UBound(fs)
+        Cells(r, c + 1).Value = fs(c)
+    Next
+    Next
+Application.ScreenUpdating = True
     If (0 < n) Then
@@ -162,7 +190,7 @@
         ReDim str(1 To n)
         '--- フォルダパスを格納 ---'
@@ -176,7 +204,7 @@
         Dim strTmp() As String
         'フォルダパスを指定してすべてのサブフォルダを取得
@@ -186,7 +214,7 @@
             str(i) = f.Path
             strTmp = GetFolderPath(str(i))  '再帰的呼び出し
@@ -200,7 +228,7 @@
             End If
             'サブフォルダ内にさらにフォルダがあればその分だけ配列を拡張
@@ -214,7 +242,7 @@
             Next j
             i = i + m + 1
@@ -222,11 +250,11 @@
     End If
     GetFolderPath = str
 End Function
@@ -246,7 +274,7 @@
     End If
     Exit Function
@@ -254,12 +282,16 @@
 ERROR_:
     IsEmptyArray = True
 End Function
 ```

困っていることの変更

2020/07/01 03:43

投稿

ichigo15

スコア14

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -68,27 +68,31 @@
-（1）と（2）は問題ありません
-（3）～（5）が困っております。
+（3）です。
+　http://www.fingeneersblog.com/1610/
+　　↑
+　こちらのサイトを参照させていただいたのですが何もおこりません
+　どうやったらフォルダの一覧を取得できるようになるのでしょうか？
+　B列に1次フォルダ、C列に2次フォルダ、D列に3次フォルダ・・・・
-（3）はパスの一覧は作れると思いますが、フォルダだけの一覧を作成することができません
+　入力箇所はB13からで、階層フォルダは次の行に入力できるようになりたいです。
-（5）は似たようなものを参照して作成することができたのですが下層部のフォルダの作成が
-　　　できません
-　　　例でいうと、テスト1の中にテスト2～4の作成はできました
-　　　テスト5～7の作成がわかりません
-ご指導頂けますでしょうか。
+　ご指導頂けますでしょうか。
-宜しくお願いいたします
+　宜しくお願いいたします
@@ -96,62 +100,166 @@
-フォルダを作成するコードです
-A6にフォルダのパス、B6～にフォルダ名としています
+[フォルダパス]は取得したいフォルダのパスを入力しました。
-できれば作成先を探して指定するようにしたいと思っております。
 ```ここに言語名を入力
-Sub フォルダ作成()
-    Dim Path As String
+'--- サブフォルダのパス一覧を配列に取得する ---'
-    Path = Range("A6").Value
+Public Sub GetAllSubFolderPath()
-    Dim i As Long
-    For i = 6 To Range("B6").End(xlDown).Row
+    '--- フォルダ一覧を取得したいフォルダのパス ---'
-        Dim FolderName As String
+    Dim folderPath As String
-        FolderName = Cells(i, 2).Value
+    folderPath = "[フォルダパス]"
+    '--- フォルダパスを取得する ---
+    Dim folderList As Variant
+    folderList = GetFolderPath(folderPath)
+End Sub
+'--- サブフォルダを再帰的に取得する関数 ---'
+Public Function GetFolderPath(folderPath As String) As String()
+    '--- ファイルシステムオブジェクト ---'
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    '--- フォルダ数を格納する変数 ---'
+    Dim n As Variant
+    n = fso.GetFolder(folderPath).SubFolders.Count
+    If (0 < n) Then
+        '--- フォルダパスを格納する配列 ---'
+        Dim str() As String
+        ReDim str(1 To n)
+        '--- フォルダパスを格納 ---'
+        Dim i As Long
+        Dim j As Long
+        Dim m As Long
+        i = 1
-        Dim NewDirPath As String
+        Dim strTmp() As String
-        NewDirPath = Path & "\" & FolderName
-        If Dir(NewDirPath, vbDirectory) = "" Then
+        'フォルダパスを指定してすべてのサブフォルダを取得
+        Dim f As Object
-            MkDir Path & "\" & FolderName
+        For Each f In fso.GetFolder(folderPath).SubFolders
+            str(i) = f.Path
+            strTmp = GetFolderPath(str(i))  '再帰的呼び出し
+            If (Not IsEmptyArray(strTmp)) Then
+                m = UBound(strTmp, 1)
+            Else
+                m = 0
-        End If
+            End If
+            'サブフォルダ内にさらにフォルダがあればその分だけ配列を拡張
+            n = UBound(str, 1)
+            ReDim Preserve str(1 To n + m)
+            For j = 1 To m
+                str(i + j) = strTmp(j)
-    Next i
+            Next j
-    MsgBox "終了しました。"
+            i = i + m + 1
+        Next f
-End Sub
+    End If
+    GetFolderPath = str
+End Function
+'--- 配列が空かどうかを判定する関数 ---'
+Public Function IsEmptyArray(arrayTmp As Variant) As Boolean
+On Error GoTo ERROR_
+    If (0 < UBound(arrayTmp, 1)) Then
+        IsEmptyArray = False
+    End If
+    Exit Function
+ERROR_:
+    IsEmptyArray = True
+End Function
 ```

コードや内容を変更

2020/06/19 03:50

投稿

ichigo15

スコア14

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -8,25 +8,23 @@
 （例）
 　テスト1　　⇒　テスト2　　⇒    テスト5　　⇒    テスト7
-　　　　　　　　　　　　　　　　   テスト6
+  テスト1　　⇒　テスト2　　⇒    テスト6
+  テスト1　　⇒  テスト3
-　　　　　　　　 テスト3
-　　　　　　　　 テスト4
+  テスト1　　⇒  テスト4
@@ -44,7 +42,21 @@
 C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5\テスト7
+イメージは、下記のとおりです。
+（1）フォルダを選ぶ
+（2）（1）のパスをExcelに表示
+（3）（1）のフォルダ一覧をExcelに作成
+（4）フォルダを選ぶ
+（5）（4）のフォルダに（3）のフォルダを作成
@@ -52,23 +64,27 @@
-ファイルの整理にファイルリストをマクロで作成しています
-同じようにファルダのリストを作成して
+(困っていること）
-もしくは、ファルダのパスからフォルダを作成できないかと
-思っておりますが何をどうしてよいのか分かりません
-①フォルダを指定
+（1）と（2）は問題ありません
-②フォルダ内のフォルダをリスト化
+（3）～（5）が困っております。
-③指定の箇所にリストのフォルダを作成
+（3）はパスの一覧は作れると思いますが、フォルダだけの一覧を作成することができません
+（5）は似たようなものを参照して作成することができたのですが下層部のフォルダの作成が
+　　　できません
+　　　例でいうと、テスト1の中にテスト2～4の作成はできました
+　　　テスト5～7の作成がわかりません
 ご指導頂けますでしょうか。
@@ -80,156 +96,62 @@
-ファイルのリストを作成しているマクロです。
+フォルダを作成するコードです
+A6にフォルダのパス、B6～にフォルダ名としています
-全然関係ないようでしたら申し訳ございません。
+できれば作成先を探して指定するようにしたいと思っております。
 ```ここに言語名を入力
-Sub getFileList()
+Sub フォルダ作成()
+    Dim Path As String
-    Dim start_x As Long: start_x = X
+    Path = Range("A6").Value
-    Dim start_y As Long: start_y = Y
-    Dim maxRow, maxCol
-    Dim searchFolderPath As String
-    Dim checkFolderPath
-    Application.ScreenUpdating = False
+    Dim i As Long
-    On Error Resume Next
+    For i = 6 To Range("B6").End(xlDown).Row
+        Dim FolderName As String
+        FolderName = Cells(i, 2).Value
+        Dim NewDirPath As String
+        NewDirPath = Path & "\" & FolderName
-    searchFolderPath = Worksheets(FOLDERPATH).Range("B3").Value
+        If Dir(NewDirPath, vbDirectory) = "" Then
+            MkDir Path & "\" & FolderName
+        End If
-    ' ファイルの存在チェック
+    Next i
-    checkFolderPath = Dir(searchFolderPath, vbDirectory)
-    If searchFolderPath = "" Or checkFolderPath = "" Then
+    MsgBox "終了しました。"
-        MsgBox ERRORMESSAGE, vbCritical
-        End
-    End If
-    ' シートの初期化
-    maxRow = Worksheets(FOLDERPATH).Cells(Rows.Count, X).End(xlUp).Row
-    maxCol = Worksheets(FOLDERPATH).Cells(Y, Columns.Count).End(xlToLeft).Column
-    Worksheets(FOLDERPATH).Range(Cells(Y, X), Cells(maxRow + Y, maxCol + X)).ClearContents
-    '　ファイル一覧作成
-    Call printFileList(searchFolderPath, start_x, start_y)
-    ' フォーマット整形
-    Columns("B:F").Select
-    Columns("B:F").EntireColumn.AutoFit
-    Range("A1").Select
-    Application.ScreenUpdating = True
 End Sub
 ```
-```ここに言語を入力
-Private Sub printFileList(searchFolderPath As String, ByRef start_x, ByRef start_y)
-    Dim fso As New FileSystemObject
-    Dim folderList As Folders
-    Dim folderName As folder
-    Dim fileName As File
-    Dim str As String
-    Dim slashNum As Long
-    Set folderList = fso.GetFolder(searchFolderPath).SubFolders
-    'フォルダ内のファイル名の取得
-    For Each fileName In fso.GetFolder(searchFolderPath).Files
-        slashNum = InStrRev(fileName.Path, "\")
-        'セルにパスとファイル名を書き込む
-        Worksheets(FOLDERPATH).Cells(start_y, start_x).Value = Mid(fileName.Path, slashNum + 1)
-        Worksheets(FOLDERPATH).Cells(start_y, start_x + 1).Value = Left(fileName.Path, slashNum - 1)
-        Worksheets(FOLDERPATH).Cells(start_y, start_x + 2).Value = Format(fileName.Size / 1024, "0.#0") & " バイト"
-        Worksheets(FOLDERPATH).Cells(start_y, start_x + 3).Value = fileName.DateCreated
-        Worksheets(FOLDERPATH).Cells(start_y, start_x + 4).Value = fileName.DateLastModified
-        start_y = start_y + 1
-    Next
-    ' サブフォルダ一覧取得　再帰処理
-    For Each folderName In folderList
-        Call printFileList(folderName.Path, start_x, start_y)
-    Next
-End Sub
-```
-。

問題点の変更

2020/06/18 04:01

投稿

ichigo15

スコア14

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -4,17 +4,69 @@
 あるフォルダの中に入っているフォルダ（下層部まで）を全て指定のフォルダ内に作成したいです
+フォルダの作成場所はPC内だけでなく、サーバー上も想定しております
+（例）
+　テスト1　　⇒　テスト2　　⇒    テスト5　　⇒    テスト7
+　　　　　　　　　　　　　　　　   テスト6
+　　　　　　　　 テスト3
+　　　　　　　　 テスト4
+C:\Users\〇〇〇\Documents\テスト1\テスト2
+C:\Users\〇〇〇\Documents\テスト1\テスト3
+C:\Users\〇〇〇\Documents\テスト1\テスト4
+C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5
+C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト6
+C:\Users\〇〇〇\Documents\テスト1\テスト2\テスト5\テスト7
 ### 発生している問題・エラーメッセージ
-ファイルリストを作成しているマクロでパスも取得しています
+ファイルの整理にファイルリストをマクロで作成しています
+同じようにファルダのリストを作成して
-このパスから作成することができればと思っていますが
+もしくは、ファルダのパスからフォルダを作成できないかと
-どこから手を付けてよいか分かりません
+思っておりますが何をどうしてよいのか分かりません
+①フォルダを指定
+②フォルダ内のフォルダをリスト化
+③指定の箇所にリストのフォルダを作成
@@ -28,6 +80,12 @@
+ファイルのリストを作成しているマクロです。
+全然関係ないようでしたら申し訳ございません。
 ```ここに言語名を入力
 Sub getFileList()