ステップイン（F8）では実行できるが、ボタンに登録したマクロを実行すると固まる（無限ループ？）してしまう

不思議な現象が起きており、ご質問させていただきました。
下記のコードでループでフォルダ構造をセルに出力するgetFolderStruct()を利用しておりました。

本コードについて、毎月実行しているのですが、今月から急に実行できなくなりました。
ここで実行できなくなるというのは、ボタンに登録したマクロをクリックで実行したときに、具体的に無限ループ（？）のような状況が発生し、ブックが固まります。下記のスクリーンショットで見る限り、'ここのループのどこかで固まることが分かっています。
どこで問題が発生しているのか切り分けるためにステップイン（F8）で進むと何故かエラー（無限ループ）が発生せずにマクロ自体実行することができます。
取得しているフォルダパス名が長すぎたり無効な文字列を含んでいたりするのかなということで調べたところ、これも問題がなさそうに思えます。何よりF8で問題ないので、切り分け的にはそこではないとは思っています。

完全に手詰まりになってしまったのですが、何かお知恵を拝借できれば幸いです。
宜しくお願い申し上げます。

vbaSub
1Dim i As Long
2Dim j As Long
3Dim YYYYMM As String
4Dim fileName As String
5Dim Dic As Object
6Dim buf As String
7Dim itemsdic As Variant
8
9Dim eachPath As String
10Dim deepPath As String
11Dim hypLink As Hyperlink
12
13Dim adr As String
14Dim deepAdr As String
15
16Dim fso As Object
17Dim n As Long
18Dim m As Integer
19
20Set fso = CreateObject("Scripting.FileSystemObject")
21
22YYYYMM = Cells(6, 4).Value
23
24If YYYYMM = "" Then
25 MsgBox "YYYYMMに出力したいフォルダパスを入力してね" & vbCrLf & "「処理を終了します」"
26 Exit Sub
27End If
28
29If Cells(4, 6).Value <> "" Then
30 MsgBox "DebugAreaをクリーンにしてください" & vbCrLf & "「処理を終了します」"
31 Exit Sub
32End If
33
34fileName = Dir(ThisWorkbook.path & "\" & YYYYMM & "\*", vbDirectory)
35
36
37Set Dic = CreateObject("Scripting.Dictionary")
38
39Do While fileName <> ""
40  If fileName <> "." And fileName <> ".." Then
41  Dic.Add fileName, fileName
42  End If
43  fileName = Dir()
44Loop
45
46i = 4
47 For Each itemsdic In Dic
48   
49   eachPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\*", vbDirectory)
50    Do While eachPath <> ""
51    adr = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\" & eachPath
52    
53     If eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath = "合算" Then
54      Cells(i, 6).Value = itemsdic
55      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
56        Anchor:=Cells(i, 7), _
57        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
58      TextToDisplay:=eachPath)
59      
60      deepPath = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\合算"
61      n = fso.GetFolder(deepPath).SubFolders.Count
62      
63      i = i + 1
64      m = i + n
65      For j = i To m
66       Cells(j, 6).Value = itemsdic
67       Cells(j, 7).Value = ">"
68      Next
69      
70      i = i + n
71      
72    
73     ElseIf eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath <> "合算" Then
74      Cells(i, 6).Value = itemsdic
75      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
76        Anchor:=Cells(i, 7), _
77        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
78      TextToDisplay:=eachPath)
79      
80      i = i + 1
81     End If
82     eachPath = Dir()
83    Loop
84 Next
85 
86 Dim k As Long
87 Dim camPath As String
88 Dim camAdr As String
89 
90 k = 4
91 Do While Cells(k, 7) <> ""
92'ここのループのどこかで固まる
93  If Cells(k, 7) = "合算" Then
94    camPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\*", vbDirectory)
95    Do While camPath <> ""
96     camAdr = ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath
97      If camPath <> "." And camPath <> ".." And GetAttr(camAdr) = 16 Then
98        Set hypLink = ActiveSheet.Cells(k + 1, 8).Hyperlinks.Add( _
99        Anchor:=Cells(k + 1, 8), _
100        Address:=".\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath, _
101      TextToDisplay:=camPath)
102      k = k + 1
103      End If
104     camPath = Dir()
105    Loop
106  Else
107  k = k + 1
108  End If
109  
110  
111 Loop
112
113End Sub
114

追加コード

vba
1Sub getFolderStruct()
2Dim i As Long
3Dim j As Long
4Dim YYYYMM As String
5Dim fileName As String
6Dim Dic As Object
7Dim buf As String
8Dim itemsdic As Variant
9
10Dim eachPath As String
11Dim deepPath As String
12Dim hypLink As Hyperlink
13
14Dim adr As String
15Dim deepAdr As String
16
17Dim fso As Object
18Dim n As Long
19Dim m As Integer
20
21Set fso = CreateObject("Scripting.FileSystemObject")
22
23YYYYMM = Cells(6, 4).Value
24
25If YYYYMM = "" Then
26 MsgBox "YYYYMMに出力したいフォルダパスを入力してね" & vbCrLf & "「処理を終了します」"
27 Exit Sub
28End If
29
30If Cells(4, 6).Value <> "" Then
31 MsgBox "DebugAreaをクリーンにしてください" & vbCrLf & "「処理を終了します」"
32 Exit Sub
33End If
34
35fileName = Dir(ThisWorkbook.path & "\" & YYYYMM & "\*", vbDirectory)
36
37
38Set Dic = CreateObject("Scripting.Dictionary")
39
40Do While fileName <> ""
41  If fileName <> "." And fileName <> ".." Then
42  Dic.Add fileName, fileName
43  Debug.Print fileName
44  End If
45  fileName = Dir()
46Loop
47
48i = 4
49 For Each itemsdic In Dic
50
51   
52   eachPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\*", vbDirectory)
53    Do While eachPath <> ""
54    adr = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\" & eachPath
55    
56     Debug.Print ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\*"
57 Debug.Print itemsdic
58 Debug.Print eachPath <> "."
59 Debug.Print eachPath <> ".."
60 Debug.Print eachPath
61 Debug.Print adr ' 検索するとちゃんと存在する
62 Debug.Print GetAttr(adr) = 16 'ここが環境によってfalseになったりする
63 Debug.Print eachPath = "合算"
64 Debug.Print "--------------------------"
65    
66     If eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath = "合算" Then
67      Cells(i, 6).Value = itemsdic
68      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
69        Anchor:=Cells(i, 7), _
70        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
71      TextToDisplay:=eachPath)
72      
73      deepPath = ThisWorkbook.path & "\" & YYYYMM & "\" & itemsdic & "\合算"
74      n = fso.GetFolder(deepPath).SubFolders.Count
75      
76      i = i + 1
77      m = i + n
78      For j = i To m
79       Cells(j, 6).Value = itemsdic
80       Cells(j, 7).Value = ">"
81      Next
82      
83      i = i + n
84      
85    
86     ElseIf eachPath <> "." And eachPath <> ".." And GetAttr(adr) = 16 And eachPath <> "合算" Then
87      Cells(i, 6).Value = itemsdic
88      Set hypLink = ActiveSheet.Cells(i, 7).Hyperlinks.Add( _
89        Anchor:=Cells(i, 7), _
90        Address:=".\" & YYYYMM & "\" & itemsdic & "\" & eachPath, _
91      TextToDisplay:=eachPath)
92      
93      i = i + 1
94     End If
95     eachPath = Dir()
96    Loop
97 Next
98 
99 Dim k As Long
100 Dim camPath As String
101 Dim camAdr As String
102 
103 k = 4
104Do While Cells(k, 7) <> ""
105    If Cells(k, 7) = "合算" Then
106      camPath = Dir(ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\*", vbDirectory)
107        Do While camPath <> ""
108            camAdr = ThisWorkbook.path & "\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath
109            If camPath <> "." And camPath <> ".." And GetAttr(camAdr) = 16 Then
110                Set hypLink = ActiveSheet.Cells(k + 1, 8).Hyperlinks.Add( _
111                Anchor:=Cells(k + 1, 8), _
112                Address:=".\" & YYYYMM & "\" & Cells(k, 6) & "\" & "合算\" & camPath, _
113                TextToDisplay:=camPath)
114                k = k + 1
115            End If
116            camPath = Dir()
117        Loop
118    Else
119    k = k + 1
120    End If
121    k = k + 1 'ここは必要であることが判明
122Loop
123
124End Sub

Zuishin

2023/01/18 05:08 編集

ステップ実行で止まらないのであれば、実行中に変数の値を出力してどこでとまっているかを特定してみては？特に camPath に気をつけてください。これが "" の時にはループが止まらないと思います。

pig_vba

2023/01/18 05:09

一旦上位ループの Do While Cells(k, 7) <> ""をコメントアウトして内外ループのどちらが原因か切り分けた方がいいと思います。

tabuu

2023/01/18 05:22

ざっくりと見た感じですが下記の何れかの場合に無限ループになるようです。・Dir()関数がいつまでたってもブランクを返さない。・camPathとcamAdrの組み合わせによっては変数kが変わらない。

mako_0221

2023/01/18 06:40

皆さんコメントありがとうございます。

mako_0221

2023/01/18 06:43

コメントに基づき、あたりをつけて実行したっけ、以下の部分がループ上加筆すべきなことがわかりました。 k = k + 1 'ここは必要であることが判明ありがとうございます。一方で、異なる問題も含んでいることがわかりました。追加コードの以下の2か所です。 Debug.Print adr ' 検索するとちゃんと存在する Debug.Print GetAttr(adr) = 16 'ここが環境によってfalseになったりする

mako_0221

2023/01/18 06:46

このGetAttr(adr)の直前で出力するadrがディレクトリ検索すると確かに存在するのに、マクロを実行する環境によって、GetAttr(adr) がfalseを返してきます。ディレクトリ関連で思いつく環境の変化は一部の環境では法人のOneDriveを同期化するしたことくらいしか思いつかないのですが、少なくとも直前のDebug.Print adr では何ら問題ないパスを出力しております。

mako_0221

2023/01/18 06:47

その結果、どのIF条件分岐にも該当せずに何も実行されない環境が発生しているのが現状わかったことです。ここでまた行き詰ってしまったのですが、如何でしょうか。

Zuishin

2023/01/18 06:55

GetAttr は環境によって違う値を返すので、環境によって違う値になるのは当然かと(小泉)。

tabuu

2023/01/18 07:04

getattr vba onedrive でググると解決策がいくつかでてきますね。

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

回答1件

自己解決

突き留めました、GetAttr(adr)した結果、17が返ってきており、これを調べるとvbReadonlyのようです。
どのような環境で、このようになってしまうのかまではわからなかったのですが、
And (GetAttr(camAdr) = 16 Or GetAttr(camAdr) = 17) とすることや、 camPath = Dir(ThisWorkbook.path & "" & YYYYMM & "" & Cells(k, 6) & "" & "合算*", vbReadOnly + vbDirectory)
とすることで解決に導くことができました。

皆さんご助言ありがとうございました。

投稿2023/01/18 07:42

mako_0221

総合スコア87

pig_vba

2023/01/18 08:14 編集

ReadOnlyフラグが立っていたということですか。であれば、一応こちらの方法でも解決できると思うので一応提示しておきます。 ...And GetAttr(adr) = 16 then... ↓ ...And(GetAttr(adr) And 16) = 16 then GetAttr(adr)の結果がvbDirectoryフラグ(16)を持っているかを論理演算しています。持っていればvbReadOnlyが含まれていたとしても16が返り、持っていない（別属性）である場合は0を返します。

mako_0221

2023/01/18 08:39

こんな論理演算可能とは存じ上げなかったです、勉強になります有難うございます！

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