이 페이지에서

실무 위키›VBA 코드›Split_EachWS

Split_EachWS

Sub

범위 또는 시트를 기준열에 따라 여러 개의 시트로 나누는 VBA 매크로 명령문입니다.

예제파일 다운로드

구문 Split_EachWS 범위(시트), [기준열], [머릿글포함], [덮어쓰기], [열자동맞춤]

인수구분 형식 설명

범위(시트) 필수 Variant

여러 개의 시트로 나눌 범위 또는 범위가 입력된 시트입니다.

기준열 선택 Long

시트를 나눌 기준 열 번호입니다. 기본값은 1 입니다.

머릿글포함 선택 Boolean

TRUE일 경우 머릿글을 항상 포함하여 시트를 나눕니다. 기본값은 TRUE 입니다.

범위에 머릿글이 없을 경우 FALSE로 입력합니다.

덮어쓰기 선택 Boolean

나누어진 시트와 같은 이름의 시트가 있을 때 덮어쓸지 결정합니다. 기본값은 FALSE 입니다.

TRUE일 경우 기존 시트를 삭제한 뒤 새로운 시트로 덮어쓰기합니다.

열자동맞춤 선택 Boolean

TRUE일 경우 나누어진 시트의 열 넓이를 자동으로 맞춥니다. 기본값은 TRUE 입니다.

마스터 코드

복사한 코드는 VBA 편집기(Alt + F11) 새 모듈에 붙여넣어 사용하세요

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

Module1 · 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

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

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

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) & "|"

If Not Dict.Exists(s) Then Dict.Add s, i

Else

For i = LBound(DB) To UBound(DB)

s = DB(i, UniqueCol)

If Not Dict.Exists(s) Then Dict.Add s, i

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

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)

Else

vArr(a) = DB(i, UniqueCol)

End If

a = a + 1

GoTo Final

Parse1D:

For Each v In Dict.Keys

i = Dict(v)

vArr(a) = DB(i)

a = a + 1

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) & "|^"

vArr(i) = s

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)) & "|^"

filterArr(i) = s

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

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

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

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

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

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

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

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

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

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

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)

i = i + 1

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

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)

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)

Extract_Column = vArr

End Function

활용 예제

"직원목록" 시트에 입력된 범위를 부서명 기준으로 시트 나누기

'직원목록시트 : 부서명 | 이름 | 나이 | 직급

Sub Test()

Dim WS As Worksheet

Set WS = ThisWorkbook.Worksheets("직원목록")

'Set Rng = WS.Range("A1").CurrentRegion

Split_EachWS WS

End Sub

"직원목록" 시트의 A1:E100 범위를 직급 기준으로 시트 나누기

'직원목록시트 : 부서명 | 이름 | 나이 | 직급

Sub Test2()

Dim WS As Worksheet

Dim Rng As Range

Set WS = ThisWorkbook.Worksheets("직원목록")

Set Rng = WS.Range("A1:E100")

Split_EachWS Rng, 4

End Sub

안내사항

Get_UniqueDB·Filtered_DB·ArrayToRng 보조 함수가 있어야 동작하며, 전체 코드에 모두 포함되어 있습니다.

덮어쓰기 인수가 FALSE일 때 같은 이름의 시트가 이미 있으면 안내 메시지와 함께 실행이 중단됩니다.

4.9 (11개 평가)

최종수 프란치스코 2021.08.20 13:03

안녕하세요. 많은 도움이 되고 있습니다.
복사해서 사용하려고 하는데 에러가 뜨는데 해결 방법을 모르겠네요. 부탁합니다.
하기에서 디버그가 발생합니다.

For Each v In uDB
Set nWS = WB.Worksheets.Add(after:=Worksheets(WB.Worksheets.Count))
On Error GoTo DeleteSheet

오빠두엑셀 작성자 2021.08.24 05:11

최종수님 안녕하세요.
적어주신 내용만으로는 정확한 답변을 드리기가 어려울 것 같습니다. 어느 부분에서 어떤 오류가 발생하는지 좀 더 정확하게 적어주시겠어요?
또는 아래 디버깅 방법 포스트를 한번 확인해보세요. 명령문에서 발생하는 오류를 디버깅하는 방법을 정리해드렸습니다. (VBA 디버깅 필수 기능 부분을 확인하세요)
https://www.oppadu.com/%EC%97%91%EC%85%80-vba-%EB%94%94%EB%B2%84%EA%B9%85/

최종수 프란치스코 2021.08.26 13:55

ㅎㅎㅎ감사합니다. 방법을 바꿔서 쓰려고 하는데요.
현재는 1행만 각 시트에 동일하게 표기가 되는데 1~4행까지 각 시트에 복사되게 하고 싶습니다.
1행 부서/이름/성별/직급 =>
2행 팀
3행 본부
4행 회사
설명이 되었는지 모르겠는데 1행부터 4행까지 각 시트에 나오게 하고
5행부터 자료가 각 시트에 분산되어 표기되게 하고 싶습니다. 감사합니다.

최종수 프란치스코 2021.08.26 14:03

혹시 안되면 고유값(부서/이름/성별/직급)을 4행으로 하고 싶습니다.

오빠두엑셀 작성자 2021.08.26 18:16

안녕하세요.
이번 포스트에 적어드린 "Split_EachWS" 명령문은 시트 데이터를 구분에 따라 여러 시트로 나누는 동작을 합니다.
말씀하신 내용과는 다릅니다.
명령문 단계별 동작을 같이 적어드렸으니, 확인 후 필요한 부분을 수정해서 사용해보세요. 직접 수정을 도와드리기는 어려운 점 양해부탁드립니다.
만약 텍스트 나누기가 필요한 경우, 홈페이지에서 제공해드리는 Text_Split 함수를 사용해보시면 도움이 되실 듯 합니다.

호람쥐 2022.10.14 19:38

안녕하세요, 항상 많은 도움 얻고있습니다. 혹시 해당 부서(기준열)은 제외하고 노출시키는 방법이 있을까요?

오빠두엑셀 작성자 2022.10.16 01:23

안녕하세요.

ArrayToRng nWS.Range("A2"), fDB

단계에서 원하시는 열만 선택해서 출력하도록 열 번호를 지정하면 됩니다.
ArrayToRng 함수에대한 설명은 아래 링크를 참고해보세요!
https://www.oppadu.com/vba-arraytorng-함수/

호람쥐 2022.10.24 16:54

안녕하세요, 말씀주신대로 참고하여 해당 위치에만도 넣어보고, 하단부에도 함께 넣어보고, 등등 했으나 오류넘버9가 뜨네요.. 혹시 알 수 있을까요? 감사합니다.

오빠두엑셀 작성자 2022.10.28 17:18

안녕하세요.
Runtime 9 오류는 개체가 비어있거나 범위가 잘못되었을 때 발생합니다.
ArrayToRng 코드 중,

Cols = Split(ColumnNo, ",")

이 부분에 중단점을 찍고 각 변수의 값이 잘 설정되었는지 (값이 비어있거나 하지 않는지) 한번 확인해보세요.

창룡 2022.10.15 19:25

안녕하세요 많은 도움이 되고 있습니다.
엑셀 시트 나누기까지는 적용을 했는데 나누었더니 yyyy-mm-dd h:mm:ss 으로 되었던 년월일시분초 셀서식이 깨지네요.
셀서식 유지하면서 시트 나누기를 하는 방법은 없을까요?

오빠두엑셀 작성자 2022.10.15 23:09

안녕하세요.
나눠진 파일에서 아래 코드를 추가해 원하는 범위의 셀 서식을 변경해보세요

ActiveSheet.Range("범위").NumberFormat = "yyyy-mm-dd h:mm:ss"

캐나다 2022.10.17 21:28

나누기 전의 셀서식(내용있는 셀의 테두리 조건부 서식) 등을 유지하면서 쪼갤수는 없을까요'

오빠두엑셀 작성자 2022.10.18 17:36

안녕하세요.
셀의 서식까지 같이 붙여넣기 하시려면 본 코드에 사용된 방식이 아닌 범위 필터링 -> 복사/붙여넣기(PasteSpecial 옵션을 PasteAll로 설정) 하시면 됩니다.
관련 내용은 구글에 vba filter and copy paste 로 검색하시면 많은 내용이 있으니 한번 참고해보세요.^^

you 2022.12.20 03:41

이렇게 좋은 사이트가 있는지 이제야 알게되었어요.
위에 예제보고 공부 열심히 하고있는데요. 제가 첨부한 스크린샷처럼, 한 worksheet안에 표가 여러개 있어요. csv파일을 xlsx로 변경한거라 텍스트 파일처럼 쭉~ 표들이 여러개 한 워크시트에 있어요. 원하는건 각각의 표를 한개씩 새로원 워크시트로 나눠 보내는건데, 위의 강의 내용을 어떻게 이용할수있을까요? 답글부탁드릴께요. 접근방법을 알려주시면 또 열심히 한번 해볼께요. 미리 감사드립니다.

해피벼리 2023.05.03 23:08

안녕하세요~ 항상 궁금한 사항 있을때마다 많은 도움 받고 있습니다.
시트 분리시에 두가지 열조건을 기준으로 시트분리는 어떻게 수정해야할까요? ^^;;

오빠두엑셀 작성자 2023.05.05 02:42

안녕하세요.
코드 중 시트를 나누기 위한 DB를 생성하는 부분을 수정하면 됩니다. 두 열의 데이터를 합친 임시키를 만들거나, DB를 복수로 생성해서 작업하는 것도 가능합니다.
만약 VBA 코드 작성이 어려울 경우, 시트 데이터 내에서 두 열을 합친 임시 키 (예: "A" & "B") 를 수식으로 작성한 후, 임시 키를 기준으로 시트를 분리해보시길 바랍니다.
감사합니다.

다니엘 2023.09.15 23:00

안녕하세요. 항상 많은 도움 받고 있습니다.
표를 인수가 아니라 그냥 행 10줄씩 시트로 나누기하려면 어떻게 해야하죠?
서식이나 셀간격등 그대로 시트로 분리만 하고싶은데 방법이 있을까요?

오빠두엑셀 작성자 2023.09.18 20:52

안녕하세요.
for 문을 아래와 같이 작성해서 매 10행마다 시트를 분리할 수 있습니다.

for i = 1 to x

   for j = 1 to 10

      r = i*10+j

      'r을 참조하여 코드 작성

...

위 형식으로 코드를 한번 작성해보세요.
감사합니다.

소다현 2023.10.27 21:28

안녕하세요. 이글의 강의는 없는지요?

간새 2023.11.12 17:58

열을 추가해서사용하려고 C열,D열 추가했더니 13번 유형 오류가 발생합니다. 범위 설정을 어떻게 바꿔야 할지요? 하기에서 디버그가 발생합니다.
Split_EachWS Rng, WS.Range("G1").Value, , WS.Range("G2").Value

오빠두엑셀 작성자 2023.11.14 13:41

안녕하세요. 위 수식은 기준열 하나로만 동작합니다.
여러 열을 기준열로 사용해야 할 경우, A&B&C... 로 열 내용을 임시열에 통합한 후, 임시열 기준으로 시트를 나눠보세요.
제시해드린 답변이 문제를 해결하시는데 도움이 되었길 바랍니다. 감사합니다.

강민준🤗 2024.08.11 13:02

좋은 자료 감사합니다.🙇‍♂️

Split_EachWS

마스터 코드

활용 예제

안내사항

바로가기

커뮤니티

문의

[공지] 오빠두에듀 프리랜서 보조 강사 모집

[직원 채용] 오빠두엑셀이 정규직 동료를 모십니다

두드림 무료 챌린지, 새단장 프로모션