人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

●質問者: japan-nan
●カテゴリ:ビジネス・経営 コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●250ポイント

結果を一括表示しているので、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

2 ● きゃづみぃ
●250ポイント ベストアンサー
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



関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ