때로 회사에서 인사평가, 피복사이즈 조사, 명절선물등 팀별로 나누어 진행 할 때 사용하는 매크로 올려 봅니다.
1 .데이터 범위는 데이터 테이블에 있는 셀하나만 선택해도 연속된 범위를 선택되도록 코딩해놓았습니다.
2. 기준열은 자신이 선택한 열을 기준으로 중복 제거후, 각 그룹별 시트를 생성해주는 기능을 합니다.
|
Sub CategorizeData()
Dim selectedRange As Range, categoryColumn As Range, cell As Range
Dim uniqueItems As New Collection, item As Variant
Dim activeFilter As AutoFilter, copyRange As Range
Dim columnIndex As Integer, currentSheet As Worksheet
Dim newSheet As Worksheet
' 현재 활성화된 시트를 저장
Set currentSheet = ActiveSheet
' 사용자에게 데이터 범위 선택 요청
On Error Resume Next
Set selectedRange = Application.InputBox("분류할 범위를 선택하시오", "범위 선택", Type:=8)
If selectedRange Is Nothing Then Exit Sub
Set selectedRange = selectedRange.CurrentRegion ' 선택한 범위를 전체 데이터 영역으로 확장
' 기준 열 선택 요청
Set categoryColumn = Application.InputBox("분류할 열을 선택하시오", "기준열 선택", Type:=8)
If categoryColumn Is Nothing Then Exit Sub
columnIndex = categoryColumn.Column ' 선택된 열의 인덱스 저장
' 선택된 기준 열을 설정
Set categoryColumn = selectedRange.Columns(columnIndex - selectedRange.Cells(1).Column + 1)
' 필터가 활성화되지 않았다면 필터 활성화
If Not ActiveSheet.AutoFilterMode Then selectedRange.AutoFilter
Set activeFilter = ActiveSheet.AutoFilter
' 기준 열에서 고유 값 수집 (중복 제거)
On Error Resume Next
For Each cell In categoryColumn.Cells
If cell.Row > selectedRange.Row Then ' 첫 번째 행(헤더) 제외
uniqueItems.Add Item:=cell.Value, Key:=CStr(cell.Value) ' 중복 제거 후 값 추가
End If
Next cell
On Error GoTo 0
' 기존 시트 삭제 (이전에 생성된 동일 이름의 시트가 있을 경우 삭제)
Application.DisplayAlerts = False
For Each item In uniqueItems
For Each newSheet In Worksheets
If newSheet.Name = CStr(item) Then newSheet.Delete
Next newSheet
Next item
Application.DisplayAlerts = True
' 데이터 분류 및 새로운 시트 생성
For Each item In uniqueItems
' 선택된 범위를 필터링하여 해당 항목만 표시
selectedRange.AutoFilter field:=columnIndex - selectedRange.Cells(1).Column + 1, Criteria1:=item
On Error Resume Next
Set copyRange = activeFilter.Range.SpecialCells(xlCellTypeVisible) ' 필터링된 데이터만 선택
On Error GoTo 0
' 필터링된 데이터가 있을 경우 새 시트 생성 후 복사
If Not copyRange Is Nothing Then
Set newSheet = Worksheets.Add(after:=ActiveSheet)
newSheet.Name = CStr(item)
copyRange.Copy
' 새 시트에 데이터 붙여넣기 및 서식 조정
With newSheet.Range("A1")
.PasteSpecial Paste:=xlPasteColumnWidths ' 원본 열 너비 유지
.PasteSpecial Paste:=xlPasteAll ' 전체 데이터 붙여넣기
.CurrentRegion.Rows.AutoFit ' 행 자동 맞춤
.CurrentRegion.Columns.AutoFit ' 열 자동 맞춤
End With
End If
Next item
' 원래 시트로 돌아가기 및 필터 해제
currentSheet.Select
selectedRange.AutoFilter
Application.CutCopyMode = False
End Sub
|
CategorizeData.xlsm
0.04MB