| |
一応考えてみた。
100もファイルがあると予想以上に時間がかかると思うので、
テストするときはファイルが少ない状態にしてからやってみてください。
それと、ケインさんから指摘がありますけど、１００シートもあるとファイルサイズがとんでもないようなファイルができます。
Sub 抽出()
Dim NewBook As Workbook
Dim SubBook As Workbook
Dim NewBookPath As String
Dim FolderPath As String
Dim BookPath As String
' 保存するファイル名を取得
NewBookPath = Application.GetSaveAsFilename(fileFilter:="Excel ファイル (*.xls), *.xls")
If NewBookPath <> "False" Then
' 対象ファイルがあるフォルダ(このフォルダもプログラムから指定可能)
FolderPath = "C:\任意のフォルダ名"
Application.ScreenUpdating = False
' すべての xls ファイルに対してループ
BookPath = Dir(FolderPath & "\*.xls")
Do While BookPath <> ""
Set SubBook = Workbooks.Open(FolderPath & "\" & BookPath)
If NewBook Is Nothing Then
SubBook.Worksheets(1).Copy
Set NewBook = ActiveWorkbook
Else
SubBook.Worksheets(1).Copy After:=NewBook.Sheets(NewBook.Sheets.Count)
End If
SubBook.Close
BookPath = Dir
Loop
' ファイルの保存
If Not NewBook Is Nothing Then
NewBook.SaveAs NewBookPath
NewBook.Close
End If
Application.ScreenUpdating = True
End If
End Sub
|
|
Blue
- 06/6/19(月) 17:29 -
