複数エクセルのシートをマージ

■画面レイアウト
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/538235/e0b051b1-8bfd-4b12-78aa-ab50d780ba4b.png)



■BtnFunしたのリソース
'****************************************
'入力フォルダ指定するため、
'参照ボタンイベントとする
'****************************************
Sub GetInFolder()
    Call GetFolderPath("F3")
End Sub
'****************************************
'出力フォルダするため、
'参照ボタンイベントとする
'****************************************
Sub GetOutFolder()
    Call GetFolderPath("F5")
End Sub

'****************************************
'シートをマージして作成、
'
'****************************************
Sub CreateExcel()
    Dim iRef As Long
    
    '入力項目チェックを行う
    Call InputCheck(iRef)
    
    If iRef = 0 Then
        
        Call MergeSht("F3", "F5", "F7")
    End If
    
End Sub


■SubFun下のリソース

'グローバルで格納フォルダのファイルとパスを退避した配列
Public get_folders(1000, 1) As Variant

'**************************************************
'入力項目のチェックを行うため
'空白値、存在するか
'**************************************************
Sub InputCheck(iRef As Long)
    '初期にセルの色を設定
    ActiveSheet.Range("F3").Interior.Color = xlNone
    ActiveSheet.Range("F5").Interior.Color = xlNone
    ActiveSheet.Range("F7").Interior.Color = xlNone
    '初期にエラーコードゼロ
    iRef = 0
    
    If ActiveSheet.Range("F3").Value = "" Then
        
        '赤色になる
        ActiveSheet.Range("F3").Interior.Color = RGB(250, 0, 0)
        iRef = 1
        
    End If
    
    If ActiveSheet.Range("F5").Value = "" Then
        
        '赤色になる
        ActiveSheet.Range("F5").Interior.Color = RGB(250, 0, 0)
        iRef = 1
        
    End If
    
    If ActiveSheet.Range("F7").Value = "" Then
        
        '赤色になる
        ActiveSheet.Range("F7").Interior.Color = RGB(250, 0, 0)
        iRef = 1
        
    End If
    
    '入力空白チェック
    If iRef = 1 Then
        
        MsgBox "入力してください", vbCritical, "入力エラー"
        Exit Sub
        
    End If
    
    'フォルダの存在チェック
    If Dir(ActiveSheet.Range("F3").Value, vbDirectory) = "" Then
        '赤色になる
        ActiveSheet.Range("F3").Interior.Color = RGB(250, 0, 0)
        iRef = 1
    End If
        
    'フォルダの存在チェック
    If Dir(ActiveSheet.Range("F5").Value, vbDirectory) = "" Then
        '赤色になる
        ActiveSheet.Range("F5").Interior.Color = RGB(250, 0, 0)
        iRef = 1
    End If
    
    
    '入力存在チェック
    If iRef = 1 Then
        
        MsgBox "指定したフォルダは存在しません", vbCritical, "存在エラー"
        Exit Sub
        
    End If
    
End Sub

'**************************************************
'フォルダ参照ダイアログを表示し、
'選択されたフォルダパスを書き込む
'**************************************************
Sub GetFolderPath(rangeName As String)
  Dim folderPath As Variant
  
  With Application.FileDialog(msoFileDialogFolderPicker)
   If .Show = 0 Then
   folderPath = ""
   Else
     folderPath = .SelectedItems(1)
   End If
 
  End With
  
 ActiveSheet.Range(rangeName).Value = folderPath
 'Sheets(1).Range(rangeName).Value = folderPath
End Sub

'**************************************************
' フォルダにファイルリストを作成
'
'**************************************************
Sub GetFolderList(find_path, Optional find_sub = 0, Optional file_type = "")

Dim fso As Object
Dim cf As Variant

Set fso = CreateObject("Scripting.FileSystemObject")
Set cf = fso.GetFolder(find_path)

Call GetSubFolder(cf, 0, find_sub, file_type)

Set fso = Nothing

End Sub
'**************************************************
' フォルダ単位で全探査、
' サブフォルダのファイルは対象とする
'**************************************************
Sub GetSubFolder(cf, cnt, Optional find_sub = 0, Optional file_type = "")

If find_sub = 1 Then 'サブフォルダのファイル取得有無
    For Each f In cf.SubFolders
        Call GetSubFolder(f, cnt, find_sub, file_type) '再帰呼出
    Next
End If

For Each f In cf.Files
    If file_type <> "" Then
        If LCase(Mid(f.Name, InStrRev(f.Name, ".") + 1)) = file_type Then '拡張子指定判定
            get_folders(cnt, 0) = f.Path
            get_folders(cnt, 1) = f.Name
            
            cnt = cnt + 1
        End If
    Else
        get_folders(cnt, 0) = f.Path
        get_folders(cnt, 1) = f.Name
        
        cnt = cnt + 1
    End If
Next

End Sub

'**************************************************
' 指定フォルダのファイルリストを取得し、
' すべてのシート２をコピーして作成
'**************************************************

Sub MergeSht(inPathRangeName As String, outPathRangeName As String, outFileNameRangeName As String)
    Dim i As Long
    Dim inPath As String
    Dim outPath As String
    Dim outFileName As String
    Dim targetWorkbook As Workbook
    Dim newWorkbook As Workbook
    Dim filePath As String
    
    
    inPath = ActiveSheet.Range(inPathRangeName).Value
    outPath = ActiveSheet.Range(outPathRangeName).Value
    outFileName = ActiveSheet.Range(outFileNameRangeName).Value
    
    
    Set newWorkbook = Workbooks.Add



    '対象フォルダ直下のファイルリストを取得
    Call GetFolderList(inPath, 1)
    
    For i = 0 To 1000
        If get_folders(i, 0) = "" Then
            Exit For
        End If
        
        'ファイルパスを取得
        filePath = get_folders(i, 0)
        
        '拡張子判断
        If CheckExtentionName(filePath) <> 0 Then
            GoTo NOTNAME
        End If
        

        
        'Set targetWorkbook = Workbooks.Open(Filepath)

        Set targetWorkbook = GetObject(filePath)
        '対象ファイルからコピーする（シート番号２のみ）
        targetWorkbook.Sheets(1).Copy After:=newWorkbook.Worksheets(1)
        '対象ファイル閉じる
        targetWorkbook.Close
        
        
NOTNAME:
    Next i
    
    '初期化に生成したシートを削除
    Application.DisplayAlerts = False
    newWorkbook.Sheets("sheet1").Delete
    Application.DisplayAlerts = True

    
    '作成エクセルを指定パスに保存する
    newWorkbook.SaveAs outPath + "\" + outFileName
    '作成ファイル閉じる
    newWorkbook.Close

    
End Sub

'**************************************************
'ファイルの拡張子を取得
' 不正のエクセルを除くために（ZIPとか）使用
' "xls" または、"xlsx"の場合、０を返し
'**************************************************

Function CheckExtentionName(filePath)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim ExtentionName As String
    
    '読み取りファイルの拡張子
    ExtentionName = fso.GetExtensionName(filePath)
    
    If ExtentionName = "xls" Or ExtentionName = "xlsx" Then
        
        CheckExtentionName = 0
    Else
        CheckExtentionName = 1
    End If
    
End Function


ここまで、以上!

![undefined]()