| |
動作未確認です。
別フォルダに、コピーのファイルを何個か用意して、試して下さい。
（いきなり、大事なデータで試さないで下さい。）
マクロブックの開かれているシートに、抽出します。
問題点などありましたら、連絡下さい。
Sub Sample()
Dim myObj As Object
Dim myDir As String
Dim myFileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Long
'フォルダ選択ダイアログの表示
Set myObj = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)
If myObj Is Nothing Then Exit Sub
myDir = myObj.Items.Item.Path
If Right(myDir, 1) <> "\" Then myDir = myDir & "\"
'フォルダ内のExcelファイル検出
myFileName = Dir(myDir & "*.xls")
With ThisWorkbook.ActiveSheet
.Cells.ClearContents 'クリア
.Range("A1").Value = "ブック名"
.Range("B1").Value = "見積もり工数時間"
.Range("C1").Value = "TOTAL時間"
.Range("D1").Value = "超過時間"
Do While myFileName <> ""
If myFileName = ThisWorkbook.Name Then myFileName = ""
'ブック開く
Set wb = Workbooks.Open(myDir & myFileName)
Set ws = wb.Worksheets("合計")
'データを入力する最下行を求める
r = .Range("A65536").End(xlUp).Offset(1).Row
.Cells(r, 1).Value = wb.Name 'ブック名
.Cells(r, 2).Value = ws.Range("D1").Value '見積もり工数時間
.Cells(r, 3).Value = ws.Range("C15").Value 'TOTAL時間
.Cells(r, 4).Value = ws.Range("C17").Value '超過時間
'ブック閉じる
wb.Close
myFileName = Dir()
Loop
End With
End Sub
|
|
