여러 엑셀 파일 합치기 (VBA)

Option Explicit

' ExcelQuest: merge the FIRST worksheet of other Excel files in this folder.
' 1 = copy each first sheet, including formatting and formulas.
' 2 = append values; row 1 is the header and must match across files.
Public Sub MergeExcelFiles()
    Dim choice As Variant
    Do
        choice = Application.InputBox( _
            Prompt:="1 = 파일마다 다른 시트로 모으기" & vbCrLf & _
                    "2 = 한 시트에 아래로 이어 붙이기", _
            Title:="엑셀퀘스트 - 1 또는 2 입력", Type:=1)
        If VarType(choice) = vbBoolean Then Exit Sub
        If choice = 1 Or choice = 2 Then Exit Do
        MsgBox "1 또는 2를 입력하세요.", vbInformation
    Loop
    MsgBox MergeFolder(CLng(choice)), vbInformation, "엑셀퀘스트"
End Sub

Public Function MergeFolder(ByVal mode As Long) As String
    Dim dest As Workbook, src As Workbook, opened As Workbook
    Dim sourceSheet As Worksheet, outputSheet As Worksheet, logSheet As Worksheet
    Dim copied As Worksheet, lastCell As Range, sourceRange As Range
    Dim fso As Object, item As Object, files As Object
    Dim names As Variant, fileName As String, fullPath As String, extension As String
    Dim i As Long, j As Long, logRow As Long, lastRow As Long, lastCol As Long
    Dim nextRow As Long, startRow As Long, rowCount As Long, expectedCols As Long
    Dim good As Long, skipped As Long, totalRows As Long, beforeCount As Long
    Dim headerReady As Boolean, isOpen As Boolean, writing As Boolean
    Dim oldScreen As Boolean, oldEvents As Boolean, oldAlerts As Boolean
    Dim oldSecurity As Long, oldStatus As Variant, settingsSaved As Boolean
    Dim reason As String, fatalMessage As String, temp As Variant

    On Error GoTo FatalError
    Set dest = ThisWorkbook
    If mode <> 1 And mode <> 2 Then Err.Raise vbObjectError + 1, , "Invalid mode."
    If Len(dest.Path) = 0 Then
        MergeFolder = "Save this workbook as an .xlsm file in the source folder first."
        Exit Function
    End If
    If dest.ProtectStructure Then
        MergeFolder = "The destination workbook structure is protected."
        Exit Function
    End If

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = CreateObject("Scripting.Dictionary")
    For Each item In fso.GetFolder(dest.Path).Files
        fileName = item.Name
        extension = LCase$(fso.GetExtensionName(fileName))
        If extension = "xlsx" Or extension = "xlsm" Or _
           extension = "xlsb" Or extension = "xls" Then
            If Left$(fileName, 2) <> "~$" And _
               StrComp(item.Path, dest.FullName, vbTextCompare) <> 0 Then
                files.Add fileName, item.Path
            End If
        End If
    Next item
    If files.Count = 0 Then
        MergeFolder = "No other Excel files were found in this folder."
        Exit Function
    End If
    names = files.Keys
    For i = LBound(names) To UBound(names) - 1
        For j = i + 1 To UBound(names)
            If StrComp(CStr(names(i)), CStr(names(j)), vbTextCompare) > 0 Then
                temp = names(i): names(i) = names(j): names(j) = temp
            End If
        Next j
    Next i

    oldScreen = Application.ScreenUpdating
    oldEvents = Application.EnableEvents
    oldAlerts = Application.DisplayAlerts
    oldSecurity = Application.AutomationSecurity
    oldStatus = Application.StatusBar
    settingsSaved = True
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.AutomationSecurity = 3

    Set logSheet = dest.Worksheets.Add(After:=dest.Sheets(dest.Sheets.Count))
    logSheet.Name = UniqueSheetName(dest, "Merge_Log")
    logSheet.Cells(1, 1).Value2 = "File"
    logSheet.Cells(1, 2).Value2 = "Status"
    logSheet.Cells(1, 3).Value2 = "Data rows"
    logSheet.Cells(1, 4).Value2 = "Result / reason"
    logRow = 2
    If mode = 2 Then
        Set outputSheet = dest.Worksheets.Add(After:=dest.Sheets(dest.Sheets.Count))
        outputSheet.Name = UniqueSheetName(dest, "Merged_Data")
    End If
    nextRow = 2

    For i = LBound(names) To UBound(names)
        On Error GoTo FileError
        Set src = Nothing
        Set copied = Nothing
        writing = False
        rowCount = 0
        beforeCount = dest.Sheets.Count
        fileName = CStr(names(i))
        fullPath = CStr(files(fileName))
        Application.StatusBar = "Merging " & CStr(i + 1) & "/" & files.Count & ": " & fileName
        isOpen = False
        For Each opened In Application.Workbooks
            If StrComp(opened.FullName, fullPath, vbTextCompare) = 0 Then isOpen = True
        Next opened
        If isOpen Then
            reason = "Close this source workbook and try again."
            GoTo SkipFile
        End If
        Set src = Application.Workbooks.Open(Filename:=fullPath, UpdateLinks:=0, _
            ReadOnly:=True, Password:="", WriteResPassword:="", _
            IgnoreReadOnlyRecommended:=True, AddToMru:=False, Notify:=False)
        If TypeName(src.Sheets(1)) <> "Worksheet" Then
            reason = "The first tab is not a worksheet."
            GoTo SkipFile
        End If
        Set sourceSheet = src.Sheets(1)
        If mode = 1 Then
            sourceSheet.Copy After:=dest.Sheets(dest.Sheets.Count)
            Set copied = dest.Sheets(dest.Sheets.Count)
            copied.Name = UniqueSheetName(dest, fso.GetBaseName(fileName))
            copied.Visible = xlSheetVisible
            reason = copied.Name
        Else
            Set lastCell = sourceSheet.Cells.Find(What:="*", After:=sourceSheet.Cells(1, 1), _
                LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
            If lastCell Is Nothing Then
                reason = "Empty sheet."
                GoTo SkipFile
            End If
            lastRow = lastCell.Row
            Set lastCell = sourceSheet.Cells.Find(What:="*", After:=sourceSheet.Cells(1, 1), _
                LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
            lastCol = lastCell.Column
            Set sourceRange = sourceSheet.Range(sourceSheet.Cells(1, 1), sourceSheet.Cells(lastRow, lastCol))
            If IsNull(sourceRange.MergeCells) Then
                reason = "Merged cells are not supported in mode 2."
                GoTo SkipFile
            ElseIf sourceRange.MergeCells Then
                reason = "Merged cells are not supported in mode 2."
                GoTo SkipFile
            End If
            If headerReady Then
                If lastCol <> expectedCols Then
                    reason = "Column count differs from the first file."
                    GoTo SkipFile
                End If
                For j = 1 To expectedCols
                    If IsError(sourceSheet.Cells(1, j).Value2) Then
                        reason = "Header contains an error."
                        GoTo SkipFile
                    End If
                    If CStr(sourceSheet.Cells(1, j).Value2) <> CStr(outputSheet.Cells(1, j).Value2) Then
                        reason = "Header or column order differs from the first file."
                        GoTo SkipFile
                    End If
                Next j
            Else
                For j = 1 To lastCol
                    If IsError(sourceSheet.Cells(1, j).Value2) Then
                        reason = "Header contains an error."
                        GoTo SkipFile
                    End If
                    If Len(Trim$(CStr(sourceSheet.Cells(1, j).Value2))) = 0 Then
                        reason = "All columns must have a header in row 1."
                        GoTo SkipFile
                    End If
                Next j
            End If
            rowCount = lastRow - 1
            If rowCount > outputSheet.Rows.Count - nextRow + 1 Then
                reason = "Not enough rows remaining in the output sheet."
                GoTo SkipFile
            End If
            startRow = nextRow
            writing = True
            If Not headerReady Then
                sourceSheet.Cells(1, 1).Resize(1, lastCol).Copy
                outputSheet.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
            End If
            If rowCount > 0 Then
                sourceSheet.Cells(2, 1).Resize(rowCount, lastCol).Copy
                outputSheet.Cells(nextRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
            End If
            expectedCols = lastCol
            headerReady = True
            nextRow = nextRow + rowCount
            totalRows = totalRows + rowCount
            writing = False
            reason = outputSheet.Name
        End If
        good = good + 1
        WriteLog logSheet, logRow, fileName, "OK", rowCount, reason
        GoTo CloseFile

RollbackFile:
        On Error GoTo FatalError
        If mode = 1 And dest.Sheets.Count > beforeCount Then
            dest.Sheets(dest.Sheets.Count).Delete
        End If
        If mode = 2 And writing Then
            If rowCount > 0 Then outputSheet.Cells(startRow, 1).Resize(rowCount, lastCol).Clear
            If Not headerReady Then outputSheet.Rows(1).Clear
        End If
SkipFile:
        skipped = skipped + 1
        WriteLog logSheet, logRow, fileName, "SKIPPED", 0, reason
CloseFile:
        Application.CutCopyMode = False
        If Not src Is Nothing Then src.Close SaveChanges:=False
        Set src = Nothing
        On Error GoTo FatalError
    Next i
    logSheet.Rows(1).Font.Bold = True
    logSheet.Columns("A:D").AutoFit
    If mode = 2 Then
        If headerReady Then
            outputSheet.Rows(1).Font.Bold = True
            outputSheet.UsedRange.Columns.AutoFit
        End If
        outputSheet.Activate
    Else
        logSheet.Activate
    End If
    MergeFolder = "Completed: " & good & " file(s)" & vbCrLf & _
        "Skipped: " & skipped & " file(s)" & vbCrLf
    If mode = 2 Then MergeFolder = MergeFolder & "Data rows: " & totalRows & vbCrLf
    MergeFolder = MergeFolder & "Check " & logSheet.Name & ", then save the workbook."
    GoTo CleanUp

FileError:
    reason = "Error " & Err.Number & ": " & Err.Description
    Resume RollbackFile

FatalError:
    fatalMessage = "Stopped: " & Err.Description
    MergeFolder = fatalMessage & vbCrLf & "Review any partial output and the log before saving."
CleanUp:
    On Error Resume Next
    Application.CutCopyMode = False
    If Not src Is Nothing Then src.Close SaveChanges:=False
    If settingsSaved Then
        Application.AutomationSecurity = oldSecurity
        Application.EnableEvents = oldEvents
        Application.DisplayAlerts = oldAlerts
        Application.ScreenUpdating = oldScreen
        Application.StatusBar = oldStatus
    End If
End Function

Private Sub WriteLog(ByVal ws As Worksheet, ByRef r As Long, _
    ByVal fileName As String, ByVal status As String, ByVal rows As Long, ByVal detail As String)
    ws.Cells(r, 1).NumberFormat = "@"
    ws.Cells(r, 1).Value2 = fileName
    ws.Cells(r, 2).Value2 = status
    ws.Cells(r, 3).Value2 = rows
    ws.Cells(r, 4).NumberFormat = "@"
    ws.Cells(r, 4).Value2 = detail
    r = r + 1
End Sub

Private Function UniqueSheetName(ByVal wb As Workbook, ByVal proposed As String) As String
    Dim bad As Variant, ch As Variant, candidate As String, suffix As String
    Dim n As Long, found As Boolean, sh As Object
    bad = Array("\", "/", ":", "*", "?", "[", "]", "'", vbCr, vbLf)
    For Each ch In bad
        proposed = Replace(proposed, CStr(ch), "_")
    Next ch
    proposed = Trim$(proposed)
    If Len(proposed) = 0 Then proposed = "Sheet"
    If LCase$(proposed) = "history" Then proposed = "History_"
    candidate = Left$(proposed, 31)
    Do
        found = False
        For Each sh In wb.Sheets
            If StrComp(sh.Name, candidate, vbTextCompare) = 0 Then found = True
        Next sh
        If Not found Then Exit Do
        n = n + 1
        suffix = "_" & CStr(n)
        candidate = Left$(proposed, 31 - Len(suffix)) & suffix
    Loop
    UniqueSheetName = candidate
End Function

• 1번: 각 파일의 첫 번째 시트를 실행 파일 안의 별도 시트로 복사합니다. 서식과 수식을 유지합니다. 다른 시트를 참조하는 수식은 원본 파일 연결이 남을 수 있습니다. 동일한 시트 이름이 있으면 _1, _2처럼 번호를 붙입니다.

• 2번: 각 파일의 첫 번째 시트를 한 시트에 값과 표시 형식으로 이어 붙입니다. 첫 정상 파일의 1행을 제목으로 쓰고, 모든 파일의 2행부터 마지막 사용 행까지 가져옵니다. 열 개수, 제목, 열 순서가 같아야 합니다. 빈 제목, 병합 셀, 빈 시트는 건너뜁니다. 원본에 합계 행이나 중간 제목이 있으면 데이터처럼 들어가므로 미리 정리하세요. 숨긴 행과 필터로 가린 행도 포함합니다. 파일명 오름차순으로 처리합니다.

• 공통: .xlsx / .xlsm / .xlsb / .xls 지원. 하위 폴더와 임시 잠금 파일(~$)은 제외합니다. 실행 파일 자신은 제외하며, 원본은 읽기 전용으로 열고 저장하지 않습니다. 암호 등으로 열지 못한 파일과 이미 열려 있는 파일은 건너뛰고 로그를 남깁니다. 첫 탭이 차트 시트인 파일은 건너뜁니다. 재실행하면 새로운 결과 시트와 로그를 만듭니다. 이전 결과를 덮어쓰지 않습니다. 이전 결과를 다른 엑셀 파일로 저장해 같은 폴더에 두면 다음 실행에서 원본으로 포함됩니다.