| |
こんにちは
各ファイルの「Sheet1」のC24を抽出すると決め打ちして、
Sub test()
Dim mShell As Object
Dim mFol As Object
Dim FolPath As String
Dim fso As Object
Dim mF As Object
Dim f As Object
Dim i As Long
Dim sSh As Worksheet
Set sSh = ThisWorkbook.Worksheets("Sheet1")
Set mShell = CreateObject("Shell.Application")
Set mFol = mShell _
.BrowseForFolder(0, "フォルダを選択して下さい", 0)
If mFol Is Nothing Then Exit Sub
FolPath = mFol.Items().Item().Path
Set mFol = Nothing
Set mShell = Nothing
With Application
.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set mF = fso.GetFolder(FolPath).Files
i = 1
On Error Resume Next
For Each f In mF
If StrConv(fso.GetExtensionName(f.Name), vbLowerCase) = "xls" Then
sSh.Cells(i, 1) = Left(f.Name, Len(f.Name) - 4)
sSh.Cells(i, 2) = Application.ExecuteExcel4Macro( _
"'" & FolPath & "\[" & f.Name & "]Sheet1'!R24C3")
i = i + 1
End If
Next
.ScreenUpdating = True
End With
Set fso = Nothing
Set mF = Nothing
End Sub
|
|
ウッシ
- 05/4/8(金) 13:31 -
