特定フォルダ配下のファイルの特定セルの値を取得する

2012/12/26

Option Explicit

Private Sub CommandButton1_Click()
    Dim Shell, myPath, strPath, i
    
    i = 2
    Set Shell = CreateObject("Shell.Application")
    Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "")
    
    If myPath Is Nothing Then Exit Sub

    strPath = myPath.Items.Item.Path
    Range("A" & i, ActiveCell.SpecialCells(xlLastCell)).ClearContents
    
    ListFiles strPath, i
End Sub

Private Sub ListFiles(strPath, i)
    Dim objFs, objFld, objFl, strShtName, P_Path, FileNam
    
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFld = objFs.GetFolder(strPath)
    Set strShtName = ActiveSheet
    
    For Each objFl In objFld.Files
        P_Path = objFl.ParentFolder.Path
        FileNam = objFs.GetFileName(objFl.Path)
        
        strShtName.Cells(i, 2) = FileNam
        strShtName.Cells(i, 3) = ExecuteExcel4Macro("'" & P_Path & "\[" & FileNam & "]Sheet1'!R2C2")
        
        i = i + 1
    Next
End Sub