統合ファイルの作成

統合ファイルの作成マクロのソースです。

Private WB As Workbook, mergeWB As Workbook

Sub 統合マクロ()

Dim folderPath As String, fileName As String, Y As Integer, X As Integer, merge_X As Integer, chk As Boolean, copyRange As Range

'初期値設定
Y = 1
X = 1
merge_X = 1
chk = False
folderPath = Range("B5") & "\"
mergeFile = "統合ファイル.xlsx"
fileName = Dir(folderPath & "\*.xlsx")

'統合ファイルの存在確認　※存在する場合は削除して新規作成
Do While fileName <> ""
    If fileName = mergeFile Then
        
        Kill folderPath & mergeFile
        
        Set mergeWB = newFile(folderPath & mergeFile)
        
        chk = True
        
    End If
    
    fileName = Dir()
Loop

'統合ファイルが存在しない場合は作成する
If chk = False Then

    Set mergeWB = newFile(folderPath & mergeFile)
    
End If

'統合作業
fileName = Dir(folderPath & "\*.xlsx")

Do While fileName <> ""

    '統合ファイルの場合はスキップ
    If fileName = mergeFile Then
    
        GoTo con
    
    End If
    
    'ファイルを開き表全体をコピー
    Set WB = Workbooks.Open(folderPath & "\" & fileName)
    
    Set copyRange = WB.Sheets(1).Range("A1").CurrentRegion
    copyRange.Copy
    mergeWB.Sheets(1).Cells(1, merge_X).PasteSpecial Paste:=xlPasteValues
    
    'コピー元ファイルの列数を取得
    Do While WB.Sheets(1).Cells(1, X) <> ""
    
        X = X + 1
    
    Loop
    
    'クローズ
    WB.Close SaveChanges:=False
    
    '統合ファイルの最終列をセットしてXは初期化
    merge_X = merge_X + X - 1
    X = 1
    
con:
    
    fileName = Dir()
    
Loop
    
    Range("A1").Select
    mergeWB.Close SaveChanges:=True
    
    MsgBox "統合完了しました！"
End Sub

Function newFile(filePath As String) As Workbook

'Excelファイルを新規作成する
Set mergeWB = Workbooks.Add
Application.DisplayAlerts = False
mergeWB.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True

Set newFile = mergeWB

End Function