'*******************************************************************************
' フォルダを指定すると、フォルダ内のエクセルファイルを開いて、
' 任意のシートをコピーして集約用ファイルにコピーするマクロ
' (集約用ファイルはダイアログで指定したフォルダの1階層上に作成されます)
'*******************************************************************************
Option Explicit
''
'取得したい内容に応じて随時変更して欲しい項目たち
''
'SHEETNAME_NG_WORD-データを取得したく無いシート名に含まれる名前を逐次追加
'それぞれのシートのコピーを集約用ファイル名
Public Const PASTEFILENAME = "AllReports"
''
'変更不要
''
'データを取得したく無いシート名に含まれる名前を指定
Public SHEETNAME_NG_WORD As Variant
'現在のシート数
Public NOWSHEETCOUNT As Integer
'*******************************************************************************
' フォルダ選択ダイアログにて、コピーしたいEXCELファイルが入っているフォルダを
' 取得する
'*******************************************************************************
Function FolderSelect()
Dim dlg As FileDialog
Dim fold_path As String
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセルボタンクリック時にマクロを終了
If dlg.Show = False Then Exit Function
'フォルダーのフルパスを変数に格納
fold_path = dlg.SelectedItems(1)
'関数名に対して値を設定すると、戻り値を設定したことになる
FolderSelect = fold_path
End Function
'*******************************************************************************
' Main
'*******************************************************************************
Sub CopyExcelSheet()
Dim CPath As String
Dim F As Object
Dim i As Integer
Dim dWB As Workbook
Dim strNewFileName As String
SHEETNAME_NG_WORD = Array("参考", "old_")
NOWSHEETCOUNT = 0
'集約用ブックを作成
Set dWB = Workbooks.Add
CPath = FolderSelect()
If CPath = "" Then Exit Sub
'フォルダが同じだと2回目以降に前に作ったシートの中もコピーしてくるため、
'一つ上の階層のフォルダに作成
strNewFileName = ".\" & PASTEFILENAME
Application.ScreenUpdating = False
'フォルダ内のファイルを一つずつ取得
For Each F In CreateObject("Scripting.FileSystemObject").GetFolder(CPath).Files
If Right(F.Name, 4) = ".xls" Or Right(F.Name, 5) = ".xlsx" Then
'EXCELファイルの場合は情報取得処理
Call CopyExcelSheets(dWB, CPath, F.Name)
End If
Next
'Excelバージョンによって、ファイルの保存方法を変更
Application.DisplayAlerts = False
If Val(Application.Version) < 12 Then
dWB.SaveAs Filename:=strNewFileName
Else
dWB.SaveAs Filename:=strNewFileName, FileFormat:=XlFileFormat.xlExcel8
End If
dWB.Close
Application.ScreenUpdating = True
MsgBox "終了"
End Sub
'*******************************************************************************
' エクセルシートコピー用関数
'*******************************************************************************
Function CopyExcelSheets(dWB As Workbook, xPath As String, xName As String)
Dim xlsWkb As Object
Dim isExcelCopy As Boolean
Dim i As Integer
Dim Sht As Worksheet
'ファイルを開く
Set xlsWkb = Workbooks.Open(xPath & "\" & xName)
'ファイルからシートを抽出
For Each Sht In xlsWkb.Worksheets
isExcelCopy = True
For i = 0 To UBound(SHEETNAME_NG_WORD) - LBound(SHEETNAME_NG_WORD)
If InStr(Sht.Name, SHEETNAME_NG_WORD(i)) > 0 Then
'シート名にNGワードが合ったらコピーしない
isExcelCopy = False
End If
Next
If isExcelCopy = True Then
NOWSHEETCOUNT = NOWSHEETCOUNT + 1
'シートをコピー
Sht.Copy After:=dWB.Worksheets(dWB.Worksheets.Count)
'ActiveSheet.Cells(1).PasteSpecial Paste:=xlValues
'シート名を重複しない...ハズの値に変更
ActiveSheet.Name = NOWSHEETCOUNT & Sht.Name
Application.CutCopyMode = False
End If
Next Sht
xlsWkb.Close:
Set xlsWkb = Nothing
End Function