Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

57523 / 76732

←次へ　｜　前へ→


	【23945】Re:数あるファイルの中から

ウッシ - 05/4/8(金) 13:31 -


	引用なし

	パスワード

こんにちは

各ファイルの「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

1 hits

▼

【23081】数あるファイルの中から もえ 05/3/12(土) 13:02