質問編集履歴

調整

2023/01/18 06:42

投稿

mako_0221

スコア87

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -189,17 +189,17 @@
  Debug.Print eachPath
  Debug.Print adr ' 検索するとちゃんと存在する
  Debug.Print GetAttr(adr) = 16 'ここが環境によってfalseになったりする
- Debug.Print eachPath = "共益維持費合算"
+ Debug.Print eachPath = "合算"
  Debug.Print "--------------------------"
-     If eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath = "共益維持費合算" Then
+     If eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath = "合算" Then
-      Cells(i, 6).Value = itemsdic
+      Cells(i, 6).Value = itemsdic
-      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
+      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
-        Anchor:=Cells(i, 7), _
+        Anchor:=Cells(i, 7), _
-        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
+        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
-      TextToDisplay:=eachPath)
+      TextToDisplay:=eachPath)
-      deepPath = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\共益維持費合算"
+      deepPath = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\合算"
       n = fso.GetFolder(deepPath).SubFolders.Count
       i = i + 1
@@ -212,7 +212,7 @@
       i = i + n
-     ElseIf eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath <> "共益維持費合算" Then
+     ElseIf eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath <> "合算" Then
       Cells(i, 6).Value = itemsdic
       Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
         Anchor:=Cells(i, 7), _
@@ -231,14 +231,14 @@
  k = 4
 Do While Cells(k, 7) <> ""
-    If Cells(k, 7) = "共益維持費合算" Then
+    If Cells(k, 7) = "合算" Then
-      camPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\*", vbDirectory)
+      camPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\*", vbDirectory)
         Do While camPath <> ""
-            camAdr = ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\" & camPath
+            camAdr = ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath
             If camPath <> "." And camPath <> ".." And GetAttr(camAdr) = 16 Then
                 Set hypLink = ActiveSheet.Cells(k + 1, 8).Hyperlinks.Add( _
                 Anchor:=Cells(k + 1, 8), _
-                Address:=".\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\" & camPath, _
+                Address:=".\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath, _
                 TextToDisplay:=camPath)
                 k = k + 1
             End If

VBA

コードの追加

2023/01/18 06:41

投稿

mako_0221

スコア87

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -124,5 +124,133 @@
 End Sub
 ```
+追加コード
+```vba
+Sub getFolderStruct()
+Dim i As Long
+Dim j As Long
+Dim YYYYMM As String
+Dim fileName As String
+Dim Dic As Object
+Dim buf As String
+Dim itemsdic As Variant
+Dim eachPath As String
+Dim deepPath As String
+Dim hypLink As Hyperlink
+Dim adr As String
+Dim deepAdr As String
+Dim fso As Object
+Dim n As Long
+Dim m As Integer
+Set fso = CreateObject("Scripting.FileSystemObject")
+YYYYMM = Cells(6, 4).Value
+If YYYYMM = "" Then
+ MsgBox "YYYYMMに出力したいフォルダパスを入力してね" & vbCrLf & "「処理を終了します」"
+ Exit Sub
+End If
+If Cells(4, 6).Value <> "" Then
+ MsgBox "DebugAreaをクリーンにしてください" & vbCrLf & "「処理を終了します」"
+ Exit Sub
+End If
+fileName = Dir(ThisWorkbook.path & "\" & YYYYMM & "\*", vbDirectory)
+Set Dic = CreateObject("Scripting.Dictionary")
+Do While fileName <> ""
+  If fileName <> "." And fileName <> ".." Then
+  Dic.Add fileName, fileName
+  Debug.Print fileName
+  End If
+  fileName = Dir()
+Loop
+i = 4
+ For Each itemsdic In Dic
+   eachPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\*", vbDirectory)
+    Do While eachPath <> ""
+    adr = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\" & eachPath
+     Debug.Print ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\*"
+ Debug.Print itemsdic
+ Debug.Print eachPath <> "."
+ Debug.Print eachPath <> ".."
+ Debug.Print eachPath
+ Debug.Print adr ' 検索するとちゃんと存在する
+ Debug.Print GetAttr(adr) = 16 'ここが環境によってfalseになったりする
+ Debug.Print eachPath = "共益維持費合算"
+ Debug.Print "--------------------------"
+     If eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath = "共益維持費合算" Then
+      Cells(i, 6).Value = itemsdic
+      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
+        Anchor:=Cells(i, 7), _
+        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
+      TextToDisplay:=eachPath)
+      deepPath = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\共益維持費合算"
+      n = fso.GetFolder(deepPath).SubFolders.Count
+      i = i + 1
+      m = i + n
+      For j = i To m
+       Cells(j, 6).Value = itemsdic
+       Cells(j, 7).Value = ">"
+      Next
+      i = i + n
+     ElseIf eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath <> "共益維持費合算" Then
+      Cells(i, 6).Value = itemsdic
+      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
+        Anchor:=Cells(i, 7), _
+        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
+      TextToDisplay:=eachPath)
+      i = i + 1
+     End If
+     eachPath = Dir()
+    Loop
+ Next
+ Dim k As Long
+ Dim camPath As String
+ Dim camAdr As String
+ k = 4
+Do While Cells(k, 7) <> ""
+    If Cells(k, 7) = "共益維持費合算" Then
+      camPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\*", vbDirectory)
+        Do While camPath <> ""
+            camAdr = ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\" & camPath
+            If camPath <> "." And camPath <> ".." And GetAttr(camAdr) = 16 Then
+                Set hypLink = ActiveSheet.Cells(k + 1, 8).Hyperlinks.Add( _
+                Anchor:=Cells(k + 1, 8), _
+                Address:=".\" & YYYYMM & "\" & Cells(k, 6) & "\" & "共益維持費合算\" & camPath, _
+                TextToDisplay:=camPath)
+                k = k + 1
+            End If
+            camPath = Dir()
+        Loop
+    Else
+    k = k + 1
+    End If
+    k = k + 1 'ここは必要であることが判明
+Loop
+End Sub
+```
 ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-18/0f315742-4103-415e-bb02-ef806e85cc91.png)

VBA