| |
>できたらヒントでも初めから教えていただけませんか？
抽出対象は、
フォルダ ： C:\data\
ファイル ： Excelファイル(.xls)
以下のマクロを実行すると、シート上に抽出されます。
Private Sub CommandButton1_Click()
Dim ファイル As String
Dim 一覧 As String
Dim Result As Long
Application.ScreenUpdating = False
'##################################
' 同フォルダ内のExcelファイル検出
'##################################
ファイル = Dir("c:\data\*.xls")
Do While ファイル <> ""
If ファイル = ThisWorkbook.Name Then ファイル = ""
一覧 = 一覧 & Chr(13) & ファイル
ファイル = Dir()
Loop
Result = MsgBox("C:\data\ に以下のファイルが見つかりました。実行しますか？" & Chr(13) & 一覧, 4, "ファイル確認")
If Result = 7 Then
Exit Sub
End If
'########################
' データのコピー
'########################
ファイル = Dir("c:\data\*.xls")
Do While ファイル <> ""
If ファイル <> ThisWorkbook.Name Then
'ファイルを開く
Workbooks.Open Filename:="c:\data\" & ファイル
'ファイル名→Ａ列
ThisWorkbook.Worksheets("sheet1").Range("A65536").End(xlUp).Offset(1, 0).Value = _
ファイル
'セルＩ４→Ｂ列
ThisWorkbook.Worksheets("sheet1").Range("B65536").End(xlUp).Offset(1, 0).Value = _
ActiveWorkbook.ActiveSheet.Range("I4").Value
'ファイルを閉じる
ActiveWorkbook.Close
End If
ファイル = Dir()
Loop
With ThisWorkbook.Worksheets("sheet1")
.Range("A1:B1").Delete Shift:=xlUp
.Columns("A:B").AutoFit
End With
Application.ScreenUpdating = True
End Sub
|
|
