質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
86.02%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

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

mako_0221
mako_0221

総合スコア87

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

1回答

0グッド

0クリップ

281閲覧

投稿2023/01/18 04:56

編集2023/01/18 06:42

不思議な現象が起きており、ご質問させていただきました。
下記のコードでループでフォルダ構造をセルに出力する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

0

自己解決

突き留めました、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

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

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
86.02%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

同じタグがついた質問を見る

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。