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

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

ただいまの
回答率

88.90%

VBAでフォルダ管理したいです。

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 187

ice930

score 35

指定のフォルダ内のフォルダまたはファイルと、表(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は存在しない」と言う意味にはならないのでしょうか?
よろしくお願いします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • DreamTheater

    2020/07/16 10:30

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

    キャンセル

回答 1

checkベストアンサー

+1

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

'(Test_Sample_Miniature)
Sub ファイル名確認()
    Dim sPath As String
    Dim buf As String
    Dim sFlg As String
    Dim hyou As Range
    Dim lRow As Long
    Dim lCol As Long

    'Sheet側からフォルダ確認
    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
            End If
            buf = Dir
        Loop
        hyou.Offset(0, 1).Value = sFlg
    Next

    'フォルダ側からSheet確認
    lRow = Range("A5").Row
    lCol = Range("A5").Column
    buf = Dir(sPath & "*", vbDirectory)
    Do While Len(buf) > 0
        If buf <> "." And buf <> ".." Then
            sFlg = "追加:フォルダ名"
            For Each hyou In Range("A1:A5")
                If hyou = buf Then
                    sFlg = ""
                    Exit For
                End If
            Next
            If sFlg <> "" Then
                lRow = lRow + 1
                Cells(lRow, lCol) = buf
                Cells(lRow, lCol + 1) = sFlg
            End If
        End If
        buf = Dir
    Loop

End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/07/16 12:38

    無意識に全てひとつのfor内で完結させようとしていました。
    必要のない時は2つの工程に分けた方が分かりやすいですね‼
    知恵が増えました‼ありがとうございます!

    キャンセル

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

  • ただいまの回答率 88.90%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

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