vba 여러시트로 나누기
https://m.blog.naver.com/rosa0189/60133555580
약간 수정해서
Sub split_Data_As_Per_Dept()
Dim rngAll As Range, rngTitle As Range
Dim rngC As Range, rngDept As Range
Dim X As New Collection
Dim varItem
' Application.ScreenUpdating = False
If Sheets.Count > 1 Then '현재 Sheet 갯수가 1개 초과 시 중단
MsgBox "Data 시트 이외의 다른 sheet는 모두 삭제 후 재실행", 64, "시트갯수 에러"
Exit Sub
End If
Set rngAll = Range("A1").CurrentRegion '각 작업영역 설정
Set rngTitle = rngAll.Rows(1)
Set rngDept = Columns("b").SpecialCells(2).Offset(1).Resize(rngAll.Rows.Count - 1) ' specialcells(2)공백을제외한 열의 숫자,문자를 선택
For Each rngC In rngDept '각 반을 순환
' If Not IsNumeric(rngC) Then
' MsgBox "반 데이터 중 숫자아닌 문자가 있습니다.", 64, "데이터 에러" 'vbInformation
' Exit Sub
' End If
on Error Resume Next '에러 발생해도 계속 진행
X.Add rngC.Value, CStr(rngC.Value) '중복없이 컬렉션에 데이터 넣기
Next rngC
on Error GoTo 0 '에러 초기화
For Each varItem In X '컬렉션의 각 값을 순환
Sheets.Add after:=Sheets(Sheets.Count) '새로운 sheet의 추가
rngTitle.Copy Range("a1").Resize(, rngTitle.Columns.Count) '각 sheet에 제목 복사
Sheets(Sheets.Count).Name = varItem '새 sheet의 이름 변경
Next varItem
For Each rngC In rngDept '각 반의 데이터 각 sheet에 전송
rngC.Offset(, -1).Resize(, Columns.Count).Copy Sheets(rngC.Value).Cells(Rows.Count, 1).End(3)(2)
' rngC.Offset(, -1).Resize(, 5).Copy Sheets(1 + rngC).Cells(Rows.Count, 1).End(3)(2)
Next rngC
Sheets("Data").Activate 'Data 시트를 활성화
Set rngAll = Nothing '개체변수들 초기화
Set rngTitle = Nothing
Set rngDept = Nothing
End Sub
Sub delete_shts()
Dim sht As Worksheet
Application.DisplayAlerts = False
For Each sht In Worksheets
If Not (sht.Name = "Data") Then sht.Delete
Next sht
Application.DisplayAlerts = True
End Sub
시트나누기.xlsm