Attribute VB_Name = "취합매크로"
'==============================================================================
' 취합매크로 - 지점별 시트 취합 / 지점별 파일 나누기
'   (견본) (주)바이브먼트 · AI 에이전트 작성 · 데이터는 모두 가상
'
' 매크로 목록 (Alt+F8 에서 보이는 것)
'   1) 취합하기          : 지점 시트 전부를 [취합] 시트 한 곳에 모은다
'   2) 지점별파일로저장  : [취합] 시트를 지점별 새 통합문서(.xlsx)로 나눠 저장한다
'
' 설정은 [설정] 시트 A열(항목) / B열(값)에서 읽는다. 시트 이름을 코드에 박지 않는다.
' 코드에 고정된 이름은 설정 시트 이름("설정") 하나뿐이다.
'==============================================================================
Option Explicit

' 설정 시트 이름 - 이 하나만 코드에 고정
Private Const CONFIG_SHEET As String = "설정"

' 설정 항목 이름 ([설정] 시트 A열에 적힌 글자와 같아야 한다)
Private Const KEY_TARGET As String = "취합 시트 이름"
Private Const KEY_EXCLUDE As String = "제외할 시트(쉼표로 구분)"
Private Const KEY_HEADER_ROW As String = "제목 행 번호"
Private Const KEY_SOURCE_TITLE As String = "출처 열 제목"
Private Const KEY_SUBFOLDER As String = "저장 하위 폴더 이름"
Private Const KEY_PREFIX As String = "파일 이름 앞말"

' 설정이 비었을 때 쓰는 기본값
Private Const DEF_TARGET As String = "취합"
Private Const DEF_EXCLUDE As String = "사용법,설정"
Private Const DEF_HEADER_ROW As Long = 1
Private Const DEF_SOURCE_TITLE As String = "지점"
Private Const DEF_SUBFOLDER As String = "지점별_파일"
Private Const DEF_PREFIX As String = ""

' 저장 형식: 51 = xlOpenXMLWorkbook(.xlsx). 이름 상수 대신 숫자를 쓰면 LibreOffice 등에서도 동작
Private Const FILE_FORMAT_XLSX As Long = 51

' 화면/계산 설정 복원용
Private mOldCalc As Long
Private mOldEvents As Boolean
Private mFastOn As Boolean

'------------------------------------------------------------------------------
' 1) 취합하기
'   - 취합 시트와 제외 시트를 뺀 모든 시트를 왼쪽부터 순서대로 돈다
'   - 제목(헤더) 행은 맨 위에 한 번만, 맨 앞에 출처(시트 이름) 열을 붙인다
'   - 실행할 때마다 기존 취합 내용을 지우고 처음부터 다시 만든다
'   - 빈 시트 / 제목만 있는 시트 / 제목이 첫 지점과 다른 시트는 건너뛰고 알려준다
'------------------------------------------------------------------------------
Public Sub 취합하기()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsT As Worksheet
    Dim targetName As String
    Dim excludeList As String
    Dim sourceTitle As String
    Dim headerRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim baseCols As Long
    Dim baseHeader As String
    Dim thisHeader As String
    Dim nRows As Long
    Dim destRow As Long
    Dim totalRows As Long
    Dim sheetCount As Long
    Dim c As Long
    Dim skipEmpty As String
    Dim skipHeaderOnly As String
    Dim skipMismatch As String
    Dim msg As String
    Dim errNum As Long
    Dim errDesc As String

    On Error GoTo ErrHandler
    BeginFast

    Set wb = ThisWorkbook
    targetName = ReadConfig(KEY_TARGET, DEF_TARGET)
    excludeList = ReadConfig(KEY_EXCLUDE, DEF_EXCLUDE)
    sourceTitle = ReadConfig(KEY_SOURCE_TITLE, DEF_SOURCE_TITLE)
    headerRow = CLng(Val(ReadConfig(KEY_HEADER_ROW, CStr(DEF_HEADER_ROW))))
    If headerRow < 1 Then headerRow = DEF_HEADER_ROW

    ' 취합 시트 준비 (없으면 맨 뒤에 새로 만든다) 후 기존 내용 전부 지우기
    Set wsT = GetOrCreateSheet(wb, targetName)
    If wsT.AutoFilterMode Then wsT.AutoFilterMode = False
    wsT.Cells.Clear

    destRow = 2          ' 1행은 제목, 데이터는 2행부터
    baseCols = 0

    For Each ws In wb.Worksheets
        If ws.Name <> wsT.Name And Not IsExcluded(ws.Name, excludeList) Then

            lastRow = LastUsedRow(ws)
            If lastRow = 0 Then
                ' 완전히 빈 시트
                skipEmpty = AddToList(skipEmpty, ws.Name)
            ElseIf lastRow <= headerRow Then
                ' 제목 행만 있고 데이터가 없는 시트
                skipHeaderOnly = AddToList(skipHeaderOnly, ws.Name)
            Else
                lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
                thisHeader = HeaderKey(ws, headerRow, lastCol)

                If baseCols = 0 Then
                    ' 처음 만난 지점 시트의 제목을 취합 시트 1행에 한 번만 쓴다
                    baseCols = lastCol
                    baseHeader = thisHeader
                    wsT.Cells(1, 1).Value = sourceTitle
                    wsT.Cells(1, 2).Resize(1, baseCols).Value = _
                        ws.Cells(headerRow, 1).Resize(1, baseCols).Value
                    ' 숫자·날짜 서식은 첫 데이터 행의 서식을 열마다 따른다
                    For c = 1 To baseCols
                        wsT.Columns(c + 1).NumberFormat = ws.Cells(headerRow + 1, c).NumberFormat
                    Next c
                End If

                If thisHeader <> baseHeader Then
                    ' 열 구성이 다르면 섞지 않고 건너뛴다 (잘못 붙는 것보다 안전)
                    skipMismatch = AddToList(skipMismatch, ws.Name)
                Else
                    nRows = lastRow - headerRow
                    ' 값만 한 번에 옮긴다 (수식·서식이 아니라 값)
                    wsT.Cells(destRow, 2).Resize(nRows, baseCols).Value = _
                        ws.Cells(headerRow + 1, 1).Resize(nRows, baseCols).Value
                    ' 출처 열에 시트 이름 채우기
                    wsT.Cells(destRow, 1).Resize(nRows, 1).Value = ws.Name
                    destRow = destRow + nRows
                    totalRows = totalRows + nRows
                    sheetCount = sheetCount + 1
                End If
            End If
        End If
    Next ws

    ' 결과 메시지
    If totalRows = 0 Then
        msg = "취합할 데이터가 없습니다." & vbCrLf & _
              "지점 시트에 " & headerRow & "행 제목 아래로 데이터가 있는지 확인해 주세요."
    Else
        ' 제목 행 꾸미기 + 열 너비 맞추기
        With wsT.Cells(1, 1).Resize(1, baseCols + 1)
            .Font.Bold = True
            .Interior.Color = RGB(221, 235, 247)
        End With
        wsT.Cells(1, 1).Resize(destRow - 1, baseCols + 1).Columns.AutoFit

        msg = "취합 완료" & vbCrLf & vbCrLf & _
              "- 취합한 시트: " & sheetCount & "개" & vbCrLf & _
              "- 취합한 행: " & totalRows & "행 (제목 행 제외)" & vbCrLf & _
              "- 결과 시트: [" & wsT.Name & "]"
    End If
    If Len(skipEmpty) > 0 Then msg = msg & vbCrLf & "- 건너뜀(빈 시트): " & skipEmpty
    If Len(skipHeaderOnly) > 0 Then msg = msg & vbCrLf & "- 건너뜀(제목만 있음): " & skipHeaderOnly
    If Len(skipMismatch) > 0 Then msg = msg & vbCrLf & "- 건너뜀(제목이 첫 지점과 다름): " & skipMismatch

    EndFast
    wsT.Activate
    MsgBox msg, vbInformation, "취합하기"
    Exit Sub

ErrHandler:
    ' 정리 작업이 Err 를 지우기 전에 먼저 받아 둔다
    errNum = Err.Number
    errDesc = Err.Description
    EndFast
    MsgBox "취합 중 오류가 났습니다." & vbCrLf & vbCrLf & _
           "오류 번호: " & errNum & vbCrLf & _
           "내용: " & errDesc, vbExclamation, "취합하기"
End Sub

'------------------------------------------------------------------------------
' 2) 지점별파일로저장
'   - [취합] 시트의 출처 열(1열) 값별로 새 통합문서를 만들어 저장한다
'   - 저장 위치: 이 파일이 있는 폴더 아래 [저장 하위 폴더 이름] 폴더 (없으면 만든다)
'   - 같은 이름 파일이 있으면 덮어쓴다
'------------------------------------------------------------------------------
Public Sub 지점별파일로저장()
    Dim wb As Workbook
    Dim wsT As Worksheet
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim targetName As String
    Dim folderPath As String
    Dim filePath As String
    Dim prefix As String
    Dim sep As String
    Dim data As Variant
    Dim header As Variant
    Dim outArr() As Variant
    Dim branches As Collection
    Dim branch As Variant
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long
    Dim k As Long
    Dim nMatch As Long
    Dim fileCount As Long
    Dim savedList As String
    Dim oldAlerts As Boolean
    Dim errNum As Long
    Dim errDesc As String

    On Error GoTo ErrHandler
    Set wb = ThisWorkbook
    oldAlerts = Application.DisplayAlerts

    ' 저장 위치 확인 - 한 번도 저장하지 않은 파일은 폴더가 없다
    If Len(wb.Path) = 0 Then
        MsgBox "이 파일을 먼저 저장해 주세요." & vbCrLf & _
               "저장된 폴더 아래에 지점별 파일 폴더를 만듭니다.", vbExclamation, "지점별파일로저장"
        Exit Sub
    End If
    ' OneDrive·SharePoint 동기화 폴더에서 열면 Path 가 웹 주소(https://...)라 폴더를 못 만든다
    If LCase$(Left$(wb.Path, 4)) = "http" Then
        MsgBox "이 파일이 OneDrive/SharePoint 웹 경로로 열려 있어 폴더를 만들 수 없습니다." & vbCrLf & _
               "PC의 일반 폴더(예: 바탕화면)에 복사해 열고 다시 실행해 주세요.", vbExclamation, "지점별파일로저장"
        Exit Sub
    End If

    targetName = ReadConfig(KEY_TARGET, DEF_TARGET)
    If Not SheetExists(wb, targetName) Then
        MsgBox "[" & targetName & "] 시트가 없습니다. 먼저 '취합하기'를 실행해 주세요.", _
               vbExclamation, "지점별파일로저장"
        Exit Sub
    End If
    Set wsT = wb.Worksheets(targetName)

    lastRow = LastUsedRow(wsT)
    If lastRow < 2 Then
        MsgBox "[" & targetName & "] 시트에 데이터가 없습니다. 먼저 '취합하기'를 실행해 주세요.", _
               vbExclamation, "지점별파일로저장"
        Exit Sub
    End If
    lastCol = wsT.Cells(1, wsT.Columns.Count).End(xlToLeft).Column

    ' 저장 폴더 만들기 (Windows / Mac 모두 Application.PathSeparator 사용)
    sep = Application.PathSeparator
    folderPath = wb.Path & sep & ReadConfig(KEY_SUBFOLDER, DEF_SUBFOLDER)
    If Len(Dir(folderPath, vbDirectory)) = 0 Then MkDir folderPath
    prefix = ReadConfig(KEY_PREFIX, DEF_PREFIX)

    BeginFast
    Application.DisplayAlerts = False   ' 같은 이름 파일 덮어쓰기 확인창 끄기

    ' 데이터를 배열로 한 번에 읽는다 (1행 = 제목)
    data = wsT.Cells(1, 1).Resize(lastRow, lastCol).Value
    header = wsT.Cells(1, 1).Resize(1, lastCol).Value

    ' 출처 열(1열)의 지점 이름을 처음 나온 순서대로 중복 없이 모은다
    ' (Mac 에는 Scripting.Dictionary 가 없어 Collection 을 쓴다)
    Set branches = New Collection
    For r = 2 To lastRow
        If Len(Trim$(CStr(data(r, 1)))) > 0 Then
            If Not InCollection(branches, CStr(data(r, 1))) Then
                branches.Add CStr(data(r, 1)), CStr(data(r, 1))
            End If
        End If
    Next r

    For Each branch In branches
        ' 이 지점 행 수 세기
        nMatch = 0
        For r = 2 To lastRow
            If CStr(data(r, 1)) = branch Then nMatch = nMatch + 1
        Next r

        ' 이 지점 행만 담은 배열 만들기
        ReDim outArr(1 To nMatch, 1 To lastCol)
        k = 0
        For r = 2 To lastRow
            If CStr(data(r, 1)) = branch Then
                k = k + 1
                For c = 1 To lastCol
                    outArr(k, c) = data(r, c)
                Next c
            End If
        Next r

        ' 새 통합문서(시트 1장)에 제목 + 데이터 쓰기
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
        Set wsNew = wbNew.Worksheets(1)
        wsNew.Name = Left$(SafeName(CStr(branch)), 31)
        wsNew.Cells(1, 1).Resize(1, lastCol).Value = header
        wsNew.Cells(2, 1).Resize(nMatch, lastCol).Value = outArr
        For c = 1 To lastCol
            wsNew.Columns(c).NumberFormat = wsT.Cells(2, c).NumberFormat
        Next c
        With wsNew.Cells(1, 1).Resize(1, lastCol)
            .Font.Bold = True
            .Interior.Color = RGB(221, 235, 247)
        End With
        wsNew.Cells(1, 1).Resize(nMatch + 1, lastCol).Columns.AutoFit

        filePath = folderPath & sep & prefix & SafeName(CStr(branch)) & ".xlsx"
        wbNew.SaveAs Filename:=filePath, FileFormat:=FILE_FORMAT_XLSX
        wbNew.Close SaveChanges:=False
        Set wbNew = Nothing

        fileCount = fileCount + 1
        savedList = savedList & vbCrLf & "- " & prefix & SafeName(CStr(branch)) & ".xlsx (" & nMatch & "행)"
    Next branch

    Application.DisplayAlerts = oldAlerts
    EndFast
    wb.Activate
    MsgBox "지점별 파일 " & fileCount & "개를 저장했습니다." & vbCrLf & _
           "폴더: " & folderPath & vbCrLf & savedList, vbInformation, "지점별파일로저장"
    Exit Sub

ErrHandler:
    ' 정리 작업이 Err 를 지우기 전에 먼저 받아 둔다
    errNum = Err.Number
    errDesc = Err.Description
    ' 만들다 만 새 통합문서가 있으면 저장하지 않고 닫는다
    CloseQuietly wbNew
    Set wbNew = Nothing
    Application.DisplayAlerts = oldAlerts
    EndFast
    MsgBox "지점별 저장 중 오류가 났습니다." & vbCrLf & vbCrLf & _
           "오류 번호: " & errNum & vbCrLf & _
           "내용: " & errDesc, vbExclamation, "지점별파일로저장"
End Sub

'==============================================================================
' 아래는 내부 도우미 (Alt+F8 목록에 안 보이도록 Private)
'==============================================================================

' 화면 갱신·자동 계산·이벤트를 잠시 끈다 (속도 + 화면 깜빡임 방지)
Private Sub BeginFast()
    If mFastOn Then Exit Sub
    mOldCalc = Application.Calculation
    mOldEvents = Application.EnableEvents
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    mFastOn = True
End Sub

' 끈 것을 되돌린다 (오류가 나도 반드시 호출. BeginFast 전이면 아무것도 안 함)
Private Sub EndFast()
    On Error Resume Next
    If Not mFastOn Then Exit Sub
    Application.Calculation = mOldCalc
    Application.EnableEvents = mOldEvents
    Application.ScreenUpdating = True
    mFastOn = False
End Sub

' 통합문서를 저장하지 않고 닫는다 (이미 닫혔거나 Nothing 이어도 오류 없음)
Private Sub CloseQuietly(ByVal target As Workbook)
    On Error Resume Next
    If Not target Is Nothing Then target.Close SaveChanges:=False
End Sub

' [설정] 시트 A열에서 항목 이름을 찾아 B열 값을 돌려준다. 없거나 비면 기본값
Private Function ReadConfig(ByVal key As String, ByVal defaultValue As String) As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim v As String

    ReadConfig = defaultValue
    If Not SheetExists(ThisWorkbook, CONFIG_SHEET) Then Exit Function
    Set ws = ThisWorkbook.Worksheets(CONFIG_SHEET)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    For r = 1 To lastRow
        If Trim$(CStr(ws.Cells(r, 1).Value)) = key Then
            v = Trim$(CStr(ws.Cells(r, 2).Value))
            If Len(v) > 0 Then ReadConfig = v
            Exit Function
        End If
    Next r
End Function

' 시트가 있는지 확인
Private Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If ws.Name = sheetName Then
            SheetExists = True
            Exit Function
        End If
    Next ws
End Function

' 시트를 가져오고, 없으면 맨 뒤에 만든다
Private Function GetOrCreateSheet(ByVal wb As Workbook, ByVal sheetName As String) As Worksheet
    If SheetExists(wb, sheetName) Then
        Set GetOrCreateSheet = wb.Worksheets(sheetName)
    Else
        Set GetOrCreateSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        GetOrCreateSheet.Name = sheetName
    End If
End Function

' 제외 목록(쉼표 구분)에 있는 시트인지 확인 (앞뒤 공백 무시)
Private Function IsExcluded(ByVal sheetName As String, ByVal excludeList As String) As Boolean
    Dim parts() As String
    Dim i As Long
    If Len(Trim$(excludeList)) = 0 Then Exit Function
    parts = Split(excludeList, ",")
    For i = LBound(parts) To UBound(parts)
        If Trim$(parts(i)) = sheetName Then
            IsExcluded = True
            Exit Function
        End If
    Next i
End Function

' 시트에서 값이 들어 있는 마지막 행 (빈 시트면 0)
'   서식만 남은 빈 셀에 속지 않도록 UsedRange 대신 값을 뒤에서부터 찾는다
Private Function LastUsedRow(ByVal ws As Worksheet) As Long
    Dim found As Range
    Set found = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _
                              LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If found Is Nothing Then
        LastUsedRow = 0
    Else
        LastUsedRow = found.Row
    End If
End Function

' 제목 행을 비교용 문자열로 만든다 (앞뒤 공백 무시)
Private Function HeaderKey(ByVal ws As Worksheet, ByVal headerRow As Long, ByVal lastCol As Long) As String
    Dim c As Long
    Dim s As String
    For c = 1 To lastCol
        s = s & Trim$(CStr(ws.Cells(headerRow, c).Value)) & "|"
    Next c
    HeaderKey = s
End Function

' 목록 문자열에 항목 덧붙이기 ("A, B, C")
Private Function AddToList(ByVal listText As String, ByVal item As String) As String
    If Len(listText) = 0 Then
        AddToList = item
    Else
        AddToList = listText & ", " & item
    End If
End Function

' Collection 에 키가 있는지 확인
Private Function InCollection(ByVal col As Collection, ByVal key As String) As Boolean
    Dim tmp As Variant
    On Error Resume Next
    tmp = col.Item(key)
    InCollection = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

' 파일·시트 이름에 쓸 수 없는 글자를 _ 로 바꾼다
Private Function SafeName(ByVal s As String) As String
    Dim bad As Variant
    Dim i As Long
    bad = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]")
    For i = LBound(bad) To UBound(bad)
        s = Replace(s, bad(i), "_")
    Next i
    SafeName = Trim$(s)
End Function