[월보용] 데이터 합치기

소방서별 데이터 합치기 코드

추가기능으로 만들었음.

나중에 쓸라고.

Option Explicit
 
Sub Macro()
 
    Dim OldBook As Workbook
    Dim NewBook As Workbook
    Dim SingleSheet As Worksheet
    Dim fd As FileDialog
    Dim FileChosen%, i%
    Dim CopySheetIndex As Integer
    Dim tmp As String
    Dim FileName As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    
    '월보 파일 선택
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Set OldBook = ActiveWorkbook
    
    '파일선택 대화상자 옵션
    With fd
        .Title = "월보 파일 선택"
        .InitialFileName = ThisWorkbook.Path
        .InitialView = msoFileDialogViewList
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "월보파일을 선택하세요", "*.xls*"
        FileChosen = .Show
    End With
 
    If FileChosen <> -1 Then Exit Sub
    
    '시트 인덱스 입력
    CopySheetIndex = InputBox("몇번째 시트를 복사할까요")
    
    For i = 1 To fd.SelectedItems.Count
        
        With fd
            Workbooks.Open .SelectedItems(i), , True
            FileName = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
        End With
        
        Set NewBook = ActiveWorkbook
        tmp = GetStationName(FileName)
        
        '시트 복사하여 붙여넣기
        With OldBook
        
            NewBook.Sheets(CopySheetIndex).Copy After:=.Sheets(.Sheets.Count)
            
            '동일한 시트명 있으면 시트 삭제
            For Each SingleSheet In .Sheets
                If SingleSheet.Name = tmp Then
                    .Sheets(tmp).Delete
                    Exit For
                End If
            Next SingleSheet
            
            .Sheets(.Sheets.Count).Name = tmp
            
        End With
    
        NewBook.Close
        Set NewBook = Nothing
    
    Next i
    
    '서별로 시트 줄 세우기
    Call SetTheLine
    
    '참조 에러를 '중부:항만'으로 수정
    Cells.Replace What:="#REF", Replacement:="'중부:항만'", LookAt:=xlPart
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With
 
End Sub
 
Function GetStationName(MyText As String)
'관할 소방서 이름 가져오기(파일명에 ()안에 관할 소방서 이름 있으면 됨
 
    Dim Reg As Object
    
    With CreateObject("Vbscript.regexp")
    
        .Pattern = "\(([가-힇]+)\)"
        .Global = False
    
        If .test(MyText) Then
            GetStationName = .Execute(MyText)(0).submatches(0)
        End If
    
    End With
    
End Function
 
Sub SetTheLine()
'서별로 줄 세우기
 
    Dim v As Variant
    Dim i As Integer
    
    v = Array("중부", "부산진", "동래", "북부", "사하", "해운대", "금정", "남부", "강서", "기장", "항만")
    
    On Error Resume Next
    
    For i = 0 To 10
        Sheets(v(i)).Move After:=Sheets(Sheets.Count)
    Next i
    
    On Error GoTo 0
    
    Sheets(1).Activate
    
End Sub
 
Sub Auto_Open()
 
    Auto_Close
    
    On Error Resume Next
    
    With Application.CommandBars("Tools").Controls
    
        With .Add(Type:=msoControlButton)
            .FaceId = 59
            .Caption = "소방서별 자료 취합"
            .OnAction = "Macro"
        End With
    
    End With
    
    On Error GoTo 0
    
End Sub
 
Sub Auto_Close()
 
    Application.CommandBars("Tools").Reset
    
End Sub
 
 

소방서별 데이터 합치기.xlam