엑셀 시트 나누기 매크로 :: Split_EachWS 명령문

Sub Split_EachWS(Target, Optional UniqueCol As Long = 1, _
                Optional isHeader As Boolean = True, _
                Optional isOverWrite As Boolean = False, _
                Optional blnAutofit As Boolean = True)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
 
'■ Split_EachWS 함수
'■ 시트에 입력된 표를 기준에 따라 여러개의 시트로 나눕니다.
'■ 사용방법
'Split_EachWS ThisWorkbook.Worksheets("시트명"), 1
'■ 인수 설명
'_____________Target            : 여러개의 시트로 나눌 범위 또는 범위가 입력된 시트입니다.
'_____________UniqueCol         : 여러개의 시트로 나눌 기준 열 번호입니다.
'_____________isHeader          : True일 경우 나누어진 시트에 머릿글을 항상 포함합니다.
'_____________isOverWrite       : True일 경우 기존에 존재하던 시트를 지우고 덮어쓰기 합니다.
'_____________blnAutofit        : True일 경우 나누어진 시트의 열 넓이를 자동으로 맞춥니다.
'■ 사용된 보조 명령문
'Get_UniqueDB 함수
'Filtered_DB 함수
'ArrayToRng 함수
'###############################################################
 
Dim DB As Variant: Dim uDB As Variant: Dim fDB As Variant
 
Dim endRow As Long: Dim endCol As Long
Dim cRow As Long: Dim cCol As Long
 
Dim WB As Workbook: Dim v As Variant:
Dim WS As Worksheet: Dim tWS As Worksheet: Dim nWS As Worksheet
 
Dim blnPass As Boolean: blnPass = True
 
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
 
If TypeName(Target) = "Worksheet" Or TypeName(Target) = "WorkSheet" Then
    Set WS = Target
    With WS
        cRow = .UsedRange.Row
        cCol = .UsedRange.Column
        endRow = .UsedRange.Rows.Count + .UsedRange.Row - 1
        endCol = .UsedRange.Columns.Count + .UsedRange.Column - 1
        If isHeader = True Then
            DB = .Range(.Cells(cRow + 1, cCol), .Cells(endRow, endCol))
        Else
            DB = .Range(.Cells(cRow, cCol), .Cells(endRow, endCol))
        End If
    End With
Else
    With Target
        Set WS = .Parent
        cRow = .Row
        cCol = .Column
        endRow = .Rows.Count + .Row - 1
        endCol = .Columns.Count + .Column - 1
        If isHeader = True Then
            DB = WS.Range(WS.Cells(cRow + 1, cCol), WS.Cells(endRow, endCol))
        Else
            DB = Target
        End If
    End With
End If
 
 
 
Set WB = WS.Parent
uDB = Get_UniqueDB(DB, UniqueCol, True)
 
If isOverWrite = False Then
    For Each v In uDB
        For Each tWS In WB.Worksheets
            v = Replace(Replace(Replace(Replace(Replace(Replace(v, "/", "_"), "\", "_"), "*", "_"), "[", "_"), "]", "_"), ":", "_")
            If tWS.Name = v Then: MsgBox "중복 시트가 존재합니다." & vbNewLine & "[시트명 :" & tWS.Name & " ]": Exit Sub
        Next
    Next
End If
 
For Each v In uDB
    Set nWS = WB.Worksheets.Add(after:=Worksheets(WB.Worksheets.Count))
    On Error GoTo DeleteSheet
AfterDelete:
    nWS.Name = Replace(Replace(Replace(Replace(Replace(Replace(v, "/", "_"), "\", "_"), "*", "_"), "[", "_"), "]", "_"), ":", "_")
    fDB = Filtered_DB(DB, v, UniqueCol)
    If isHeader = True Then
        With WS
            .Range(.Cells(cRow, cCol), .Cells(cRow, endCol)).Copy nWS.Range(nWS.Cells(1, 1), nWS.Cells(1, endCol - cCol + 1))
            ArrayToRng nWS.Range("A2"), fDB
        End With
    Else
       ArrayToRng nWS.Range("A1"), fDB
    End If
    If blnAutofit = True Then nWS.UsedRange.EntireColumn.AutoFit
Next
 
WS.Activate
 
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
 
Exit Sub
 
DeleteSheet:
Application.DisplayAlerts = False
WB.Worksheets(v).Delete
Application.DisplayAlerts = True
Resume AfterDelete
 
End Sub
 
Function Get_UniqueDB(DB, Optional UniqueCol As Long, Optional UniqueOnly As Boolean = True) As Variant
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
 
'■ Get_UniqueDB 함수
'■ 배열의 특정열 또는 전체 열을 참조하여 고유값을 반환합니다.
'■ 사용방법
'DB = GetUnique_DB(DB)
'■ 인수 설명
'_____________DB                  : 고유값을 추출할 배열입니다.
'_____________UniqueCol      : 고유값을 참조할 열 번호입니다. 열 번호가 없을 경우 모든 열을 참조하여 고유값을 판단합니다.
'_____________UniqueOnly    :  True 일 경우 결과값으로 해당 열번호만 반환합니다. False 일 경우 결과값으로 모든 열을 반환합니다.
'###############################################################
 
Dim Dict As Object
Dim i As Long: Dim j As Long: Dim a As Long: a = 1
Dim s As String
Dim v As Variant: Dim vArr As Variant
Dim ArrD As Integer
 
Set Dict = CreateObject("scripting.dictionary")
 
On Error Resume Next
 
Do
    i = i + 1
    j = UBound(DB, i)
Loop Until Err.Number <> 0
Err.Clear
ArrD = i - 1
 
On Error GoTo 0
 
If ArrD > 1 Then
    If UniqueCol = 0 Then
        For i = LBound(DB) To UBound(DB)
            For j = LBound(DB, 2) To UBound(DB, 2)
                s = s & DB(i, j) & "|"
            Next
            If Not Dict.Exists(s) Then Dict.Add s, i
        Next
    Else
        For i = LBound(DB) To UBound(DB)
            s = DB(i, UniqueCol)
            If Not Dict.Exists(s) Then Dict.Add s, i
        Next
    End If
    If UniqueOnly = False Or UniqueCol = 0 Then
        ReDim vArr(1 To Dict.Count, LBound(DB, 2) To UBound(DB, 2))
    Else
        ReDim vArr(1 To Dict.Count)
    End If
GoTo Parse2D
Else
    For i = LBound(DB) To UBound(DB)
        s = Dict(i)
        If Not Dict.Exists(s) Then Dict.Add s, i
    Next
    ReDim vArr(1 To Dict.Count)
GoTo Parse1D
End If
 
Parse2D:
For Each v In Dict.Keys
    i = Dict(v)
    If UniqueOnly = False Or UniqueCol = 0 Then
        For j = LBound(vArr, 2) To UBound(vArr, 2)
            vArr(a, j) = DB(i, j)
        Next
    Else
        vArr(a) = DB(i, UniqueCol)
    End If
    a = a + 1
Next
GoTo Final
 
Parse1D:
For Each v In Dict.Keys
    i = Dict(v)
    vArr(a) = DB(i)
    a = a + 1
Next
GoTo Final
 
Final:
Get_UniqueDB = vArr
 
End Function
 
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
 
'■ Filtered_DB 함수
'■ 서로 다른 두 시트를 연결합니다. FromWS의 첫번째 필드는 반드시 고유값(ID)이 입력되어야 합니다.
'■ 사용방법
'Array = Filtered_DB(Get_DB(Sheet1),">=200")
'■ 인수 설명
'_____________DB                  : 데이터를 필터링 할 원본 DB 입니다.
'_____________Value             : 필터링 할 조건입니다.
'_____________FilterCol         : [선택인수] 필터링 할 검색 열입니다. 빈칸일 경우 전체 열을 대상으로 필터링합니다.
'_____________ExactMatch   : [선택인수] 정확히 일치 여부입니다. 기본값은 False(=유사일치) 입니다.
'###############################################################
 
Function Filtered_DB(DB, Value, Optional FilterCol, Optional ExactMatch As Boolean = False) As Variant
 
Dim cRow As Long
Dim cCol As Long
Dim vArr As Variant: Dim s As String: Dim filterArr As Variant:  Dim Cols As Variant: Dim Col As Variant: Dim Colcnt As Long
Dim isDateVal As Boolean
Dim vReturn As Variant: Dim vResult As Variant
Dim Dict As Object: Dim dictKey As Variant
Dim i As Long: Dim j As Long
Dim Operator As String
 
Set Dict = CreateObject("Scripting.Dictionary")
 
If Value <> "" Then
    cRow = UBound(DB, 1)
    cCol = UBound(DB, 2)
    ReDim vArr(1 To cRow)
    For i = 1 To cRow
        s = ""
        For j = 1 To cCol
            s = s & DB(i, j) & "|^"
        Next
        vArr(i) = s
    Next
 
    If IsMissing(FilterCol) Then
        filterArr = vArr
    Else
        Cols = Split(FilterCol, ",")
        ReDim filterArr(1 To cRow)
        For i = 1 To cRow
            s = ""
            For Each Col In Cols
                s = s & DB(i, Trim(Col)) & "|^"
            Next
            filterArr(i) = s
        Next
    End If
 
    If Left(Value, 2) = ">=" Or Left(Value, 2) = "<=" Or Left(Value, 2) = "=>" Or Left(Value, 2) = "=<" Then
        Operator = Left(Value, 2)
        If IsDate(Right(Value, Len(Value) - 2)) Then isDateVal = True
    ElseIf Left(Value, 1) = ">" Or Left(Value, 1) = "<" Then
        Operator = Left(Value, 1)
        If IsDate(Right(Value, Len(Value) - 1)) Then isDateVal = True
    Else: End If
 
    If Operator <> "" Then
        If isDateVal = False Then
            Select Case Operator
                Case ">"
                    For i = 1 To cRow
                        If CDbl(Left(filterArr(i), Len(filterArr(i)) - 2)) > CDbl(Right(Value, Len(Value) - 1)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case "<"
                    For i = 1 To cRow
                        If CDbl(Left(filterArr(i), Len(filterArr(i)) - 2)) < CDbl(Right(Value, Len(Value) - 1)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case ">=", "=>"
                    For i = 1 To cRow
                        If CDbl(Left(filterArr(i), Len(filterArr(i)) - 2)) >= CDbl(Right(Value, Len(Value) - 2)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                 Case "<=", "=<"
                    For i = 1 To cRow
                        If CDbl(Left(filterArr(i), Len(filterArr(i)) - 2)) <= CDbl(Right(Value, Len(Value) - 2)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
            End Select
        Else
            Select Case Operator
                Case ">"
                    For i = 1 To cRow
                        If CDate(Left(filterArr(i), Len(filterArr(i)) - 2)) > CDate(Right(Value, Len(Value) - 1)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case "<"
                    For i = 1 To cRow
                        If CDate(Left(filterArr(i), Len(filterArr(i)) - 2)) < CDate(Right(Value, Len(Value) - 1)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case ">=", "=>"
                    For i = 1 To cRow
                        If CDate(Left(filterArr(i), Len(filterArr(i)) - 2)) >= CDate(Right(Value, Len(Value) - 2)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                 Case "<=", "=<"
                    For i = 1 To cRow
                        If CDate(Left(filterArr(i), Len(filterArr(i)) - 2)) <= CDate(Right(Value, Len(Value) - 2)) Then: vArr(i) = Left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
            End Select
        End If
    Else
        If ExactMatch = False Then
            For i = 1 To cRow
                If filterArr(i) Like "*" & Value & "*" Then
                    vArr(i) = Left(vArr(i), Len(vArr(i)) - 2)
                    vReturn = Split(vArr(i), "|^")
                    Dict.Add i, vReturn
                End If
            Next
        Else
            For i = 1 To cRow
                If filterArr(i) Like Value & "|^" Then
                    vArr(i) = Left(vArr(i), Len(vArr(i)) - 2)
                    vReturn = Split(vArr(i), "|^")
                    Dict.Add i, vReturn
                End If
            Next
        End If
    End If
 
    If Dict.Count > 0 Then
        ReDim vResult(1 To Dict.Count, 1 To cCol)
        i = 1
        For Each dictKey In Dict.Keys
            For j = 1 To cCol
                vResult(i, j) = Dict(dictKey)(j - 1)
            Next
            i = i + 1
        Next
    End If
 
    Filtered_DB = vResult
Else
    Filtered_DB = DB
End If
 
End Function
 
Sub ArrayToRng(startRng As Range, Arr As Variant, Optional ColumnNo As String = "")
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ArrayToRng 함수
'▶ 배열을 범위 위로 반환합니다.
'▶ 인수 설명
'_____________startRng      : 배열을 반환할 기준 범위(셀) 입니다.
'_____________Arr               : 반환할 배열입니다.
'_____________ColumnNo   : [선택인수] 배열의 특정 열을 선택하여 범위로 반환합니다. 여러개 열을 반환할 경우 열 번호를 쉼표로 구분하여 입력합니다.
'                                               값으로 공란을 입력하면 열을 건너뜁니다.
'▶ 사용 예제
'Dim v As Variant
'ReDim v(0 to 1)
''v(0) = "a" : v(1) = "b"
'ArrayToRng Sheet1.Range("A1"), v
'▶ 사용된 보조 명령문
'Extract_Column 함수
'##############################################################
 
On Error GoTo SingleDimension:
 
Dim Cols As Variant: Dim Col As Variant
Dim X As Long: X = 1
If ColumnNo = "" Then
    startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, UBound(Arr, 2) - LBound(Arr, 2) + 1) = Arr
Else
    Cols = Split(ColumnNo, ",")
    For Each Col In Cols
        If Trim(Col) <> "" Then
            startRng.Cells(1, X).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1) = Extract_Column(Arr, CLng(Trim(Col)))
        End If
        X = X + 1
    Next
End If
Exit Sub
 
SingleDimension:
Dim tempArr As Variant: Dim i As Long
ReDim tempArr(LBound(Arr, 1) To UBound(Arr, 1), 1 To 1)
For i = LBound(Arr, 1) To UBound(Arr, 1)
    tempArr(i, 1) = Arr(i)
Next
startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, 1) = tempArr
 
End Sub
 
'########################
' 배열에서 특정 열 데이터만 추출합니다.
' Array = Extract_Column(Array, 1)
'########################
 
Function Extract_Column(DB As Variant, Col As Long) As Variant
 
Dim i As Long
Dim vArr As Variant
 
ReDim vArr(LBound(DB) To UBound(DB), 1 To 1)
For i = LBound(DB) To UBound(DB)
        vArr(i, 1) = DB(i, Col)
Next
 
Extract_Column = vArr
 
End Function