EXCEL VBAについて質問です。良い回答は300~500ptを差し上げます。

シートに各店舗リストがあり、
フォルダ内の全てのブックファイル(エクセル)の存在確認を行いたい。
無い場合は、メッセージボックスに対象店舗を表示し「OK」と「キャンセル」ボタンを設けてほしい。
条件としまして、
・フォルダ内のファイル名に規則があります。
 2011年・○○○店・確認表.XLS
・フォルダのパスは、フォルダー参照選択を使用したいです。
・[店舗リスト]シートには、A列1行から100行まで○○○店と一覧化してます。

ソースでの回答をお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/11/24 15:45:56
  • 終了:2011/12/01 15:50:03

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13481ベストアンサー獲得回数11982011/11/24 16:18:53

ポイント250pt
Sub test()
    Dim a As Long
    Dim flg As Boolean
    Dim f As String
    
    Dim ShellApp As Object
    Dim oFolder As Object
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)

    For a = 1 To Sheets("店舗リスト").Range("A1").End(xlDown).Row
        ' 2011年・○○○店・確認表.XLS
        b = "\2011年・" + Sheets("店舗リスト").Cells(a, "A") + "・確認表.xls"
            
        ' この店舗のファイルがあるかチェック
        f = Dir(oFolder.items.Item.Path & b, vbNormal)
            
        If f = "" Then
            MsgBox Sheets("店舗リスト").Cells(a, "A"), vbOKCancel
        End If
    
    Next a

End Sub



その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912011/11/24 16:14:57

ポイント250pt

結果を一括表示しているので、OK Cancel は対応していませんが、個別表示の必要があるようでしたら、コメントください。

Option Explicit
Sub CheckFiles()
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'   最終行の取得
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A1").Resize(lastRow, 1).Interior.ColorIndex = _
         Range("B1").Interior.ColorIndex  ' セルの色を戻す
    
'   フォルダの選択
    Dim folderPath
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "フォルダが選択されませんでした。"
            Exit Sub
        End If
    End With
    
    Dim fileName As String
    Dim res As String
    Dim r As Long
'   ファイルの有無の確認
    For r = 1 To lastRow
        fileName = "2011年・" & Cells(r, "A").Value & "・確認表.XLS"
        If fso.FileExists(folderPath & fileName) = False Then
            res = res & vbNewLine & fileName
            Cells(r, "A").Interior.ColorIndex = 3   ' 無いセルを赤で表示
        End If
    Next

'   結果の表示
    If res = "" Then
        MsgBox "すべてのファイルがありました。"
    Else
        MsgBox "次のファイルがありません。" & res
    End If
End Sub
id:taknt No.2

きゃづみぃ回答回数13481ベストアンサー獲得回数11982011/11/24 16:18:53ここでベストアンサー

ポイント250pt
Sub test()
    Dim a As Long
    Dim flg As Boolean
    Dim f As String
    
    Dim ShellApp As Object
    Dim oFolder As Object
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)

    For a = 1 To Sheets("店舗リスト").Range("A1").End(xlDown).Row
        ' 2011年・○○○店・確認表.XLS
        b = "\2011年・" + Sheets("店舗リスト").Cells(a, "A") + "・確認表.xls"
            
        ' この店舗のファイルがあるかチェック
        f = Dir(oFolder.items.Item.Path & b, vbNormal)
            
        If f = "" Then
            MsgBox Sheets("店舗リスト").Cells(a, "A"), vbOKCancel
        End If
    
    Next a

End Sub



コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません