VBAでﾌｫﾙﾀﾞ管理したいです。

指定のフォルダ内のフォルダまたはファイルと、表（A列）を比較し、表とフォルダが存在するときは「有り」、表に有ってフォルダが無いときは「無し」、フォルダがあって表に無いときは、「追加：フォルダ名」と入力したいです。

Sub ファイル名確認()
    Dim sPath As String
    Dim buf As String
    Dim sFlg As String
    Dim hyou As Range

    sPath = ThisWorkbook.Path & "\" & "テスト" & "\"

    For Each hyou In Range("A1:A5")
    
        buf = Dir(sPath, vbDirectory)
        sFlg = "無し"
       
        Do While Len(buf) > 0
        
            If hyou = buf Then
                sFlg = "有り"
                Exit Do
                
            ElseIf buf = hyou <> buf Then
            sFlg = "追加:" & buf
                
            End If
            buf = Dir()
        Loop
  
        hyou.Offset(, 1).Value = sFlg
    Next
End Sub

上のコードでで条件分岐し、ElseIf buf = hyou <> buf Then　で表に無いフォルダが存在した場合に、「追加：存在しないﾌｫﾙﾀﾞ」と表の隣に表示されるようにしたいです。

このコードを実行すると、存在するﾌｫﾙﾀﾞがbufに反映されて何度も同じものが表示されてしまいます。
buf = hyou <> buf
のコードは「hyouの中にbufは存在しない」と言う意味にはならないのでしょうか？
よろしくお願いします。

DreamTheater

2020/07/16 01:30

指定フォルダ直下のサブフォルダーのみを対象とするということでいいのかな？（サブフォルダーを再帰的に調べるとなるとちょっと複雑になりそう）

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

回答1件

ベストアンサー

こんな感じでどうでしょうか。

VBA
1'(Test_Sample_Miniature)
2Sub ファイル名確認()
3    Dim sPath As String
4    Dim buf As String
5    Dim sFlg As String
6    Dim hyou As Range
7    Dim lRow As Long
8    Dim lCol As Long
9
10    'Sheet側からフォルダ確認
11    sPath = ThisWorkbook.Path & "\" & "テスト" & "\"
12    For Each hyou In Range("A1:A5")
13        buf = Dir(sPath & "*", vbDirectory)
14        sFlg = "無し"
15        Do While Len(buf) > 0
16            If hyou = buf Then
17                sFlg = "有り"
18                Exit Do
19            End If
20            buf = Dir
21        Loop
22        hyou.Offset(0, 1).Value = sFlg
23    Next
24
25    'フォルダ側からSheet確認
26    lRow = Range("A5").Row
27    lCol = Range("A5").Column
28    buf = Dir(sPath & "*", vbDirectory)
29    Do While Len(buf) > 0
30        If buf <> "." And buf <> ".." Then
31            sFlg = "追加：フォルダ名"
32            For Each hyou In Range("A1:A5")
33                If hyou = buf Then
34                    sFlg = ""
35                    Exit For
36                End If
37            Next
38            If sFlg <> "" Then
39                lRow = lRow + 1
40                Cells(lRow, lCol) = buf
41                Cells(lRow, lCol + 1) = sFlg
42            End If
43        End If
44        buf = Dir
45    Loop
46
47End Sub