'*******************************************************************************
' フォルダを指定すると、フォルダ内のエクセルファイルを開いて、
' 任意のシートをコピーして集約用ファイルにコピーするマクロ
' (集約用ファイルはダイアログで指定したフォルダの1階層上に作成されます)
'*******************************************************************************
Option Explicit
''
'取得したい内容に応じて随時変更して欲しい項目たち
''
'SHEETNAME_NG_WORD-データを取得したく無いシート名に含まれる名前を逐次追加
'それぞれのシートのコピーを集約用ファイル名
Public Const PASTEFILENAME = "AllReports"
''
'変更不要
''
'データを取得したく無いシート名に含まれる名前を指定
Public SHEETNAME_NG_WORD As Variant
'現在のシート数
Public NOWSHEETCOUNT As Integer
Public Enum CellBound
RightBound = 0
Leftbound = 1
UpBound = 2
DownBound = 3
End Enum
Public Type SearchRequirement
Bound As CellBound
OffsetValue As Integer
CellName As String
End Type
Public Type SearchCellType
TargetCellName As String
TargetSheetName As String
EndOfData As String
Requirements() As SearchRequirement
End Type
'*******************************************************************************
' フォルダ選択ダイアログにて、コピーしたい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)
Call GetExcelData(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
'*******************************************************************************
' データ取得用関数
'*******************************************************************************
Function GetExcelData(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
Dim jyoken As SearchCellType
Dim Target As Range
jyoken.TargetCellName = "機能"
jyoken.TargetSheetName = ""
jyoken.EndOfData = ""
ReDim jyoken.Requirements(1)
jyoken.Requirements(0).CellName = "aa"
jyoken.Requirements(0).Bound = RightBound
jyoken.Requirements(0).OffsetValue = 4
'ファイルを開く
Set xlsWkb = Workbooks.Open(xPath & "\" & xName)
Dim FoundCell As Range, FirstCell As Range
'ファイルからシートを抽出
For Each Sht In xlsWkb.Worksheets
isExcelCopy = True
If jyoken.TargetSheetName <> "" And Sht.Name <> jyoken.TargetSheetName Then
Else
Target = SearchMatchCell(Sht, jyoken)
End If
'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 Not Target Is Nothing Then
Do
Set FoundCell = Cells.FindNext(Target)
If FoundCell.Address = Target.Address Then
Exit Function
Else
Target.Copy Destination:=dWB.Worksheets("Sheet2").Range("A1")
End If
Loop
End If
'If isExcelCopy = True Then
' NOWSHEETCOUNT = NOWSHEETCOUNT + 1
' dWB.Worksheets("Sheet2").Value = ""
'シートをコピー
'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
Function SearchMatchCell(sheet As Worksheet, searchName As SearchCellType) As Range
Dim Rng As Range
Dim FoundCell As Range, FirstCell As Range, Target As Range
Set FoundCell = sheet.Cells.Find(What:=searchName.TargetCellName, LookIn:=xlValues, LookAt:=xlWhole)
If FoundCell Is Nothing Then
'条件に見合うセルがない
Exit Function
ElseIf Not FoundCell Is Nothing And Sgn(searchName.Requirements) = 0 Then
'追加条件なし
SearchMatchCell = FoundCell
Exit Function
Else
'追加条件あり
Set FirstCell = FoundCell
Set Target = FoundCell
End If
Do
Dim j As Long
Dim isMatchCell As Boolean
For j = LBound(searchName.Requirements) To UBound(searchName.Requirements)
isMatchCell = True
'If FoundCell.MergeCells Then
' If searchName.Requirements(j).Bound = CellBound.RightBound Then
' offset = FoundCell.MergeArea.Columns.Count
' ElseIf searchName.Requirements(j).Bound = CellBound.DownBound Then
' offset = FoundCell.MergeArea.Rows.Count
' End If
'End If
Select Case searchName.Requirements(j).Bound
Case CellBound.RightBound
If sheet.Cells(FoundCell.Row, FoundCell.Column + searchName.Requirements(j).OffsetValue).Value <> _
searchName.Requirements(j).CellName Then
isMatchCell = False
Exit For
End If
Case CellBound.Leftbound
If sheet.Cells(FoundCell.Row, FoundCell.Column - searchName.Requirements(j).OffsetValue).Value <> _
searchName.Requirements(j).CellName Then
isMatchCell = False
Exit For
End If
Case CellBound.UpBound
If sheet.Cells(FoundCell.Row - searchName.Requirements(j).OffsetValue, FoundCell.Column).Value <> _
searchName.Requirements(j).CellName Then
isMatchCell = False
Exit For
End If
Case CellBound.DownBound
If sheet.Cells(FoundCell.Row + searchName.Requirements(j).OffsetValue, FoundCell.Column + searchName.Requirements(j).OffsetValue).Value <> _
searchName.Requirements(j).CellName Then
isMatchCell = False
Exit For
End If
End Select
'Msg = Msg & searchName(j).TargetCellName & vbCrLf
Next j
If isMatchCell Then
'合致したセルとして返却
SearchMatchCell = FoundCell
Exit Function
Else
Set FoundCell = sheet.Cells.FindNext(FoundCell)
If FoundCell.Address = FirstCell.Address Then
Exit Function
End If
End If
Loop
End Function