프로그램 설명
엑셀에서 피벗테이블과 유사한 기능을 수행하는 VBA매크로입니다. 피벗테이블은 세부적인 데이터 집계가 가능하고 마우스로 쉽게 커스터마이징 할 수 있는 장점이 있지만 피벗테이블 보다 간편하고 빠르게 사용할 목적으로 작성해봤습니다.
피벳테이블처럼 집계할 대상에 대하여 행과 열로 구분하여 표로 나타내며 "SUM", "COUNT", "COUNTA", "MAX", "MIN", "LARGE", "SMALL", "MEDIAN", "MODE.SNGL", "AVERAGE", "VAR.P", "VAR.S", "STDEV.P", "STDEV.S" 함수를 활용한 집계가 가능하고 선택적으로 비교연산자를 활용하여 값에 대한 조건을 부여할 수 있습니다.
사용법

사용예시

설치방법
- 아래 다운로드 링크 클릭하여 aggr.tar 다운로드 후 압축해제 프로그램으로 압축해제
- 탐색기 주소창에 %appdata%\Microsoft\AddIns 입력
- aggr.xlam 화일을 AddIns폴더에 이동
- Excel을 실행
- 상단 메뉴에서 "파일(File)"을 선택한 후, "옵션(Options)"을 클릭
- "옵션(Options)" 창에서 "추가 기능(Add-Ins)"을 선택
- "관리(Manage)" 영역에서 "Excel 추가 기능(Excel Add-ins)"을 선택하고, 하단의 "이동(Go)" 버튼을 클릭
- Aggr을 선택하고 확인 버튼을 누릅니다.
- Add-in이 성공적으로 설치되면 상단 메뉴 "추가 기능"에 AggrByItem 아이콘이 생성되고 클릭하여 실행할 수 있습니다.
- 다른 방법은로는 리본 사용자 지정탭을 만들고 추가 하여 사용할 수 도 있습니다.
사용시 유의사항
- 엑셀 2010에서 작성하였으며, 상위버전에서는 테스트하지 않았습니다.
- 출처를 표시하여 배포하는 것은 자유롭게 가능합니다. 그러나 상업적인 목적으로 이용하는 것은 허용되지 않습니다.
- 이상현상 발생시 댓글달아주세요.
다운로드
revison
rev1(20230830) : 시작셀 주소 입력시 잘못된 범위에 대한 예외처리코드 추가
rev2(20230915) : 도움말내 오타 수정
코드
module1
Option Explicit Public Sub aggr() UserForm1.Show vbModeless End Sub Public Sub aggrMain(ByRef funcNum As Long, ByRef funcName As String, ByRef k As Long, ByRef evlaueRng As Range, ByRef rowLabelRng As Range, ByRef colLabelRng As Range, ByRef evlaueCriteria As String, Optional ByRef targetRng As Range, Optional ByRef targetValue As String) Dim ws As Worksheet Set ws = ActiveSheet Dim outputColumn As String Dim rowCount As Long Dim indexDict As Object Dim aggrDict As Object Dim countDict As Object Dim sumSqDict As Object Dim evlaue As Variant Dim rowLabel As String Dim colLabel As String Dim colLabelCount As Long Dim colLabelIndex As Long Dim i As Long Dim dataArr() As Variant Dim col As Long Dim row As Long Dim key As Variant Dim innerkey As Variant Dim count As Long Dim outputRange As Range Set indexDict = CreateObject("Scripting.Dictionary") Set aggrDict = CreateObject("Scripting.Dictionary") Set countDict = CreateObject("Scripting.Dictionary") Set sumSqDict = CreateObject("Scripting.Dictionary") ' 현재셀 주소 저장(출력결과 표시할 위치) outputColumn = ActiveCell.Address rowCount = evlaueRng.Rows.count ' colLabelRng에서 유니크한 colLabel을 찾아 indexDict에 저장 For i = 1 To rowCount colLabel = colLabelRng.Cells.item(i).value If Not indexDict.Exists(colLabel) Then colLabelCount = colLabelCount + 1 indexDict.item(colLabel) = colLabelCount End If Next i ' 분류 및 집계 For i = 1 To rowCount rowLabel = rowLabelRng.Cells.item(i).value colLabelIndex = indexDict.item(colLabelRng.Cells.item(i).value) evlaue = vbNullString If evlaueCriteria <> vbNullString Then On Error Resume Next If Evaluate(evlaueRng.Cells.item(i).value & evlaueCriteria) Then evlaue = evlaueRng.Cells.item(i).value End If On Error GoTo 0 Else evlaue = evlaueRng.Cells.item(i).value End If If Not aggrDict.Exists(rowLabel) Then Set aggrDict.item(rowLabel) = CreateObject("Scripting.Dictionary") End If If Not aggrDict.item(rowLabel).Exists(colLabelIndex) Then aggrDict.item(rowLabel)(colLabelIndex) = 0 End If Select Case funcNum Case 4 To 9 If Not countDict.Exists(rowLabel & "|" & colLabelIndex) Then Set countDict.item(rowLabel & "|" & colLabelIndex) = CreateObject("Scripting.Dictionary") End If If Not countDict.item(rowLabel & "|" & colLabelIndex).Exists(evlaue) Then countDict.item(rowLabel & "|" & colLabelIndex)(evlaue) = 0 End If Case 10 To 14 If Not countDict.Exists(rowLabel) Then Set countDict.item(rowLabel) = CreateObject("Scripting.Dictionary") End If If Not countDict.item(rowLabel).Exists(colLabelIndex) Then countDict.item(rowLabel)(colLabelIndex) = 0 End If End Select Select Case funcNum Case 11 To 14 If Not sumSqDict.Exists(rowLabel) Then Set sumSqDict.item(rowLabel) = CreateObject("Scripting.Dictionary") End If If Not sumSqDict.item(rowLabel).Exists(colLabelIndex) Then sumSqDict.item(rowLabel)(colLabelIndex) = 0 End If End Select If Not IsEmpty(evlaue) And (funcNum = 3 Or (funcNum <> 3 And IsNumeric(evlaue))) And shouldPick(targetRng, targetValue, i) Then Select Case funcNum Case 1 aggrDict.item(rowLabel)(colLabelIndex) = aggrDict.item(rowLabel)(colLabelIndex) + evlaue Case 2, 3 aggrDict.item(rowLabel)(colLabelIndex) = aggrDict.item(rowLabel)(colLabelIndex) + 1 Case 4 To 9 countDict.item(rowLabel & "|" & colLabelIndex)(evlaue) = countDict.item(rowLabel & "|" & colLabelIndex)(evlaue) + 1 Case 10 aggrDict.item(rowLabel)(colLabelIndex) = aggrDict.item(rowLabel)(colLabelIndex) + evlaue countDict.item(rowLabel)(colLabelIndex) = countDict.item(rowLabel)(colLabelIndex) + 1 Case 11 To 14 aggrDict.item(rowLabel)(colLabelIndex) = aggrDict.item(rowLabel)(colLabelIndex) + evlaue countDict.item(rowLabel)(colLabelIndex) = countDict.item(rowLabel)(colLabelIndex) + 1 sumSqDict.item(rowLabel)(colLabelIndex) = sumSqDict.item(rowLabel)(colLabelIndex) + (evlaue * evlaue) End Select End If Next i ' 2차원 배열 dataArr 초기화 ReDim dataArr(1 To aggrDict.count + 1, 1 To colLabelCount + 1) dataArr(1, 1) = funcName ' dataArr의 첫 번째 행에 각 colLabel을 기록 For col = 2 To colLabelCount + 1 dataArr(1, col) = GetKeyByValue(indexDict, col - 1) Next col ' dataArr 구성 row = 2 For Each key In aggrDict.Keys dataArr(row, 1) = key For col = 2 To colLabelCount + 1 If aggrDict.item(key).Exists(col - 1) Then Select Case funcNum Case 4 To 8 Dim tempList As Collection Set tempList = New Collection For Each innerkey In countDict.item(key & "|" & col - 1).Keys count = countDict.item(key & "|" & col - 1)(innerkey) Do While count > 0 tempList.Add innerkey count = count - 1 Loop Next innerkey If funcNum = 8 Then If tempList.count > 0 Then dataArr(row, col) = getMedian(tempList) Else dataArr(row, col) = "" End If Else If tempList.count >= k Then dataArr(row, col) = getKthValue(tempList, k, funcName) Else dataArr(row, col) = "" End If End If Case 9 Dim maxCount As Long Dim mode As Double Dim shouldUpdate As Boolean maxCount = 1 shouldUpdate = True For Each innerkey In countDict.item(key & "|" & col - 1).Keys count = countDict.item(key & "|" & col - 1)(innerkey) If count = maxCount Then shouldUpdate = False ElseIf count > maxCount Then maxCount = count mode = innerkey shouldUpdate = True End If Next innerkey If shouldUpdate And maxCount > 1 Then dataArr(row, col) = mode Else dataArr(row, col) = "" End If Case 10 To 14 If countDict.item(key)(col - 1) = 0 Then dataArr(row, col) = "" Else Dim avg As Double Dim temp1 As Double Dim temp2 As Double Dim temp3 As Double Dim variance As Variant avg = aggrDict.item(key)(col - 1) / countDict.item(key)(col - 1) If funcNum = 10 Then dataArr(row, col) = avg Else temp1 = sumSqDict.item(key)(col - 1) temp2 = aggrDict.item(key)(col - 1) ^ 2 / countDict.item(key)(col - 1) If funcNum = 11 Or funcNum = 13 Then temp3 = countDict.item(key)(col - 1) Else temp3 = countDict.item(key)(col - 1) - 1 End If If temp3 > 0 Then variance = (temp1 - temp2) / temp3 Else variance = "" End If If funcNum = 11 Or funcNum = 12 Then dataArr(row, col) = variance Else If variance <> "" Then dataArr(row, col) = Sqr(variance) Else dataArr(row, col) = "" End If End If End If End If Case Else dataArr(row, col) = aggrDict.item(key)(col - 1) End Select Else dataArr(row, col) = "" End If Next col row = row + 1 Next key 'dataArr 출력 Set outputRange = ws.Range(outputColumn).Resize(row - 1, colLabelCount + 1) outputRange.value = dataArr End Sub Private Function shouldPick(ByRef rng As Range, ByRef item As String, ByRef i As Long) As Boolean If rng Is Nothing Or item = vbNullString Then shouldPick = True Else shouldPick = (rng.Cells.item(i).value = item) End If End Function Private Function GetKeyByValue(ByVal dict As Object, ByVal value As Variant) As Variant Dim key As Variant For Each key In dict.Keys If dict.item(key) = value Then GetKeyByValue = key Exit Function End If Next key End Function Private Function getMedian(ByRef coll As Collection) As Double Dim tempArr() As Variant ReDim tempArr(1 To coll.count) Dim i As Long For i = 1 To coll.count tempArr(i) = coll.item(i) Next i quickSort tempArr, 1, coll.count If coll.count Mod 2 = 0 Then getMedian = (tempArr(coll.count \ 2) + tempArr(coll.count \ 2 + 1)) / 2 Else getMedian = tempArr(coll.count \ 2 + 1) End If End Function Private Function getKthValue(ByRef coll As Collection, ByRef k As Long, ByVal funcName As String) As Double Dim tempArr() As Variant ReDim tempArr(1 To coll.count) Dim i As Long For i = 1 To coll.count tempArr(i) = coll.item(i) Next i quickSort tempArr, 1, coll.count Select Case funcName Case "MAX", "LARGE" getKthValue = tempArr(coll.count - k + 1) Case "MIN", "SMALL" getKthValue = tempArr(k) End Select End Function Private Sub quickSort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long) Dim low As Long Dim high As Long Dim temp As Variant Dim list_Separator As Variant low = first high = last list_Separator = SortArray((first + last) \ 2) Do Do While SortArray(low) < list_Separator low = low + 1 Loop Do While SortArray(high) > list_Separator high = high - 1 Loop If low <= high Then temp = SortArray(low) SortArray(low) = SortArray(high) SortArray(high) = temp low = low + 1 high = high - 1 End If Loop While low <= high If first < high Then quickSort SortArray, first, high If low < last Then quickSort SortArray, low, last End Sub
UserForm1
Option Explicit Private Sub UserForm_Initialize() With Me.ComboBox1 .List = Array("SUM", "COUNT", "COUNTA", "MAX", "MIN", "LARGE", "SMALL", "MEDIAN", "MODE.SNGL", "AVERAGE", "VAR.P", "VAR.S", "STDEV.P", "STDEV.S") .ListRows = 14 .value = "SUM" End With End Sub Private Sub ComboBox1_Change() With Me.TextBox1 If Me.ComboBox1.value = "LARGE" Or Me.ComboBox1.value = "SMALL" Then .Enabled = True .BackColor = vbWhite Else .Enabled = False .BackColor = RGB(192, 192, 192) End If End With With Me.TextBox5 If Me.ComboBox1.value = "COUNTA" Then .Enabled = False .BackColor = RGB(192, 192, 192) Else .Enabled = True .BackColor = vbWhite End If End With End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet Set ws = ActiveSheet Dim funcNum As Long Dim funcName As String Dim kth As String Dim k As Long Dim evalueRngStart As String Dim rowLabelRngStart As String Dim colLabelRngStart As String Dim evlaueCriteria As String Dim targetRngStart As String Dim targetValue As String Dim evalueRng As Range Dim rowLabelRng As Range Dim colLabelRng As Range Dim targetRng As Range Dim rngArray() As Variant Dim rngStart As Variant Dim lastRow As Long Dim i As Long Dim cell As Range Dim hasNonNumericValues As Boolean Dim userResponse As VbMsgBoxResult Dim nonNumericCells As Range Select Case Me.ComboBox1.value Case "SUM": funcNum = 1 Case "COUNT": funcNum = 2 Case "COUNTA": funcNum = 3 Case "MAX": funcNum = 4 Case "MIN": funcNum = 5 Case "LARGE": funcNum = 6 Case "SMALL": funcNum = 7 Case "MEDIAN": funcNum = 8 Case "MODE.SNGL": funcNum = 9 Case "AVERAGE": funcNum = 10 Case "VAR.P": funcNum = 11 Case "VAR.S": funcNum = 12 Case "STDEV.P": funcNum = 13 Case "STDEV.S": funcNum = 14 End Select funcName = Me.ComboBox1.value kth = Me.TextBox1.value evalueRngStart = Me.TextBox2.value rowLabelRngStart = Me.TextBox3.value colLabelRngStart = Me.TextBox4.value evlaueCriteria = Me.TextBox5.value targetRngStart = Me.TextBox6.value targetValue = Me.TextBox7.value ' k 입력값 검증 If isPositiveInteger(kth) Then k = CLng(kth) Else k = 1 End If ' target 입력범위 확인(둘다 입력하거나 둘다 입력하지 않거나) If targetRngStart <> vbNullString And targetValue = vbNullString Or targetRngStart = vbNullString And targetValue <> vbNullString Then MsgBox "선택입력값 입력시 targetRngStart, targetValue 모두 입력해야 합니다." Exit Sub End If ' 필수 입력범위 확인 If evalueRngStart = vbNullString Or rowLabelRngStart = vbNullString Or colLabelRngStart = vbNullString Then MsgBox "필수입력 범위의 시작주소 입력하세요!", vbExclamation, "입력 확인" Exit Sub End If If rowLabelRngStart = colLabelRngStart Then MsgBox "rowLabelRngStart, colLabelRngStart는 다르게 설정하세요.", vbExclamation, "입력 확인" Exit Sub End If ' 범위 초기화 rngArray = Array(evalueRngStart, rowLabelRngStart, colLabelRngStart, targetRngStart) For i = LBound(rngArray) To UBound(rngArray) If rngArray(i) = vbNullString Then ReDim Preserve rngArray(i - 1) Exit For Else If Not IsValidRange(rngArray(i)) Then MsgBox "잘못된 범위가 입력되었습니다." Exit Sub End If lastRow = ws.Cells(Rows.count, Range(rngArray(i)).Column).End(xlUp).row rngStart = ws.Range(rngArray(i)).Address Set rngArray(i) = ws.Range(rngStart & ":" & ws.Cells(lastRow, Range(rngArray(i)).Column).Address) End If Next i Set evalueRng = rngArray(0) Set rowLabelRng = rngArray(1) Set colLabelRng = rngArray(2) If UBound(rngArray) >= 3 Then Set targetRng = rngArray(3) End If ' ctiteria 입력 값 검증 If evlaueCriteria <> vbNullString Then If Not hasComparisonOperator(evlaueCriteria) Then MsgBox "value_criteria 입력시 반드시 비교연산자(=><)가 선행되야 합니다." & vbCrLf & "도움말을 참고하세요.", vbExclamation, "입력 확인" Exit Sub End If End If ' targetRng내 targetValue가 있는지 확인 If targetRngStart <> vbNullString And targetValue <> vbNullString Then If Not isValueInRange(targetValue, targetRng) Then MsgBox "targetRng내 targetValue 값을 가진 셀이 없습니다." & vbCrLf & "이럴경우 집계가 되지 않습니다.", vbExclamation, "입력 확인" Exit Sub End If End If ' evalueRng내 출력할 수 없는 문자 제거 If CheckBox1.value = True Then For Each cell In evalueRng If VarType(cell.value) = vbString Then cell.value = removeNonPrintableChars(cell.value) End If Next cell End If ' evalueRng내 문자포함 여부 확인(CountA는 제외) If funcNum <> 3 Then On Error Resume Next Set nonNumericCells = evalueRng.SpecialCells(xlCellTypeConstants, xlTextValues) On Error GoTo 0 If Not nonNumericCells Is Nothing Then userResponse = MsgBox("valueRng의 값 중에 숫자가 아닌 값이 있습니다." & vbCrLf & "숫자가 아닌 값은 무시되고 계산됩니다. 계속 진행하시겠습니까?", vbQuestion + vbYesNo) If userResponse = vbNo Then Exit Sub End If End If End If ' 입력범위 확인 If targetRngStart = vbNullString Then If Not (areRangesEqual(evalueRng, rowLabelRng) And areRangesEqual(evalueRng, colLabelRng)) Then MsgBox "세개의 범위 중 하나 이상이 다릅니다." Exit Sub Else aggrMain funcNum, funcName, k, evalueRng, rowLabelRng, colLabelRng, evlaueCriteria End If Else If Not (areRangesEqual(evalueRng, rowLabelRng) And areRangesEqual(evalueRng, colLabelRng) And areRangesEqual(evalueRng, targetRng)) Then MsgBox "네개의 범위 중 하나 이상이 다릅니다." Exit Sub Else aggrMain funcNum, funcName, k, evalueRng, rowLabelRng, colLabelRng, evlaueCriteria, targetRng, targetValue End If End If Unload Me End Sub Private Sub CommandButton2_Click() Unload Me End Sub Private Sub CommandButton3_Click() UserForm2.Show End Sub Private Function areRangesEqual(ByRef range1 As Range, ByRef range2 As Range) As Boolean areRangesEqual = range1.Rows.count = range2.Rows.count And range1.Columns.count = range2.Columns.count End Function Private Function removeNonPrintableChars(ByRef inputText As String) As String Dim cleanedText As String Dim i As Long For i = 1 To Len(inputText) Dim charCode As Long charCode = AscW(Mid$(inputText, i, 1)) If charCode <> 0 And charCode > 32 And charCode <= 126 Then cleanedText = cleanedText & Mid$(inputText, i, 1) End If Next i removeNonPrintableChars = cleanedText End Function Private Function hasComparisonOperator(ByRef criteria As String) As Boolean Dim comparisonOperators As String comparisonOperators = "=><" If Len(criteria) > 0 Then hasComparisonOperator = InStr(1, comparisonOperators, Left$(criteria, 1)) > 0 Else hasComparisonOperator = False End If End Function Private Function isValueInRange(ByRef value As String, ByRef rng As Range) As Boolean Dim cell As Range For Each cell In rng If cell.value = value Then isValueInRange = True Exit Function End If Next cell isValueInRange = False End Function Private Function isPositiveInteger(ByRef str As String) As Boolean Dim num As Double str = Trim$(str) If IsNumeric(str) Then num = CDbl(str) isPositiveInteger = (Int(num) = num) And (num > 0) Else isPositiveInteger = False End If End Function Function IsValidRange(ByVal rngStr As String) As Boolean On Error Resume Next Dim rng As Range Set rng = Range(rngStr) On Error GoTo 0 IsValidRange = Not rng Is Nothing End Function
UserForm2
Option Explicit Private Sub CommandButton1_Click() Unload Me End Sub
ThisWorkBook
Option Explicit Private Const cbarName As String = "Add-ins" Private Const buttonCaption As String = "aggrByItem" Private Sub Workbook_Open() Dim obCommandBar As CommandBar Dim obButton As CommandBarButton On Error Resume Next Set obCommandBar = Application.CommandBars.item(cbarName) On Error GoTo 0 If (obCommandBar Is Nothing) Then On Error Resume Next Set obCommandBar = Application.CommandBars.Add(Name:=cbarName, Position:=msoBarTop, Temporary:=True) On Error GoTo 0 If (Not obCommandBar Is Nothing) Then Set obButton = obCommandBar.Controls.Add(Type:=msoControlButton, Temporary:=True) With obButton .Style = msoButtonIconAndCaption .Caption = buttonCaption .FaceId = 80 .TooltipText = "실행하려면 클릭하세요." .OnAction = "'" & ThisWorkbook.Name & "'!aggr" End With obCommandBar.Visible = True End If End If End Sub Private Sub Workbook_BeforeClose(ByRef Cancel As Boolean) On Error Resume Next Application.CommandBars.item(cbarName).Delete On Error GoTo 0 End Sub