나눔터  
  HOME > 나눔터 > 묻고답하기 > 엑셀
엑셀
엑셀에 대한 질문과 답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
 "000 님, 도와주세요", "부탁 드립니다.", "급합니다!" 등과 같이 막연한 제목을 달지 말아주세요.
[필독] 빠르고 정확한 답변을 얻는 16가지 Tip !
[필독] 저작권법 개정에 따른 이용안내
작성자:  

 참서리 (k5953)

추천:  2
파일:     자동필터로 항목별 시트 나누기.xlsm (24.8KB) 조회:  1073
제목:   [RE]시트 나누기 질문입니다.
     
  제 YouTube를 소개합니다.
'=====================================================
Excel,VBA,Google SpreadSheet 등 다양한 자료가 있습니다.
=====================================================
https://www.youtube.com/channel/UChR2YTnlpU9OVfLyH_09YeA



'------------------------
소스코드
'------------------------
'------------------------
Sub separate_data()
'------------------------

    Dim rngX As Range: Set rngX = Range("A1").CurrentRegion
    
    Dim shtX As Worksheet: Set shtX = ActiveSheet
    
    If shtX.AutoFilterMode Then shtX.AutoFilterMode = False
             
    Dim varX As Variant: varX = get_unique_1
    Dim v As Variant
    'Stop
    Dim sht As Worksheet
    
    Application.ScreenUpdating = False
    
    ' Sheet 삭제
    Application.DisplayAlerts = False
    For Each sht In Worksheets
        If sht.Name <> "합계" Then sht.Delete
    Next sht
    Application.DisplayAlerts = True
    
    
    For Each v In varX
       rngX.AutoFilter 2, v
       Set sht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
       sht.Name = v
       rngX.Copy sht.Range("A1")
   
    Next v
    
    shtX.Activate
    shtX.AutoFilterMode = False
    
    Application.ScreenUpdating = True
End Sub


'-------------------------
Function get_unique_1() As Variant
'-------------------------

    Dim varX As Variant: varX = Range("A1").CurrentRegion.Value
    
    Dim oList As Object: Set oList = CreateObject("System.Collections.ArrayList")
    
    Dim r As Long, v As Variant
    
    For r = 2 To UBound(varX, 1)
    
        If Not oList.contains(varX(r, 2)) Then
            oList.Add varX(r, 2)
        End If
    
    Next r
    
   oList.Sort
   
   
   get_unique_1 = oList.toArray
  
  
     
End Function
 
[불량 게시물 신고]  
참서리아래 유튜브 동영상에 자세히 설명되어 있습니다.
https://youtu.be/sKia_ax4Oro
04-04 (22:58)
삭제 ■신고
가을소고감사합니다.04-05 (17:37)
삭제 ■신고
        
  

작성일 : 2019-04-04(22:57)
최종수정일 : 2019-04-04(22:57)
 


 ◎ 관련글

  제 목   작성자   날짜
시트 나누기 질문입니다. 가을소고 2019-04-04
[RE]시트 나누기 질문입니다. 참서리 2019-04-04