[VBA] 부서별 매출정리(feat.이중 딕셔너리 + 병합)

이런 비슷한 문제를 풀어본적이 있다.

그때는 Consolidate 와 sumif를 사용하여 해결한적이 있다.

 

https://1stminokingdom.tistory.com/50

[VBA] 그룹별 합계 구하고 병합하기 (Consolidate vs Sumif)

 

한때 본인도 그런적이 있지만 딕셔너리를 가지고 노는게 참 재미질때가 있다.

해서 이번엔 문제도 비슷하거니 해서 이중 딕셔너리를 사용하여 풀어보려고 한다.

 

물론 Sumif나 Countif를 사용하여 풀면 더 간단한 문제지만 지금은 그냥 딕셔너리를 연구한다는 마음으로 봐주길 바란다.

 

처음 딕셔너리는 부서와 매출을 작업할 예정이고

두번째 딕셔너리는 부서와 부서의 반복횟수를 구하여 병합때 사용하려 한다.

 

Option Explicit
Sub 부서별_총합()

    Dim rngAll As Range: Set rngAll = [b2].CurrentRegion
    Dim rngA As Range
    Dim Dict As Object: Set Dict = CreateObject("scripting.dictionary")
    Dim DictN As Object: Set DictN = CreateObject("scripting.dictionary")
    Dim key, Vhead: Vhead = Array("부서", "매출")
    
    For Each rngA In rngAll.Columns(1).Cells
        If rngA <> "부서" Then
        
            If Dict.exists(rngA.Value) Then
                Dict(rngA.Value) = Dict(rngA.Value) + rngA(1, 3).Value    '= 부서 / 매출
                DictN(rngA.Value) = DictN(rngA.Value) + 1                 '= 부서 / 반복횟수
            Else
                Dict.Add rngA.Value, rngA(1, 3).Value
                DictN.Add rngA.Value, 1
            End If
        End If
    Next rngA
    
         [f2].Resize(1, 2) = Vhead                                        '= 부서 / 매출 헤드
         [f3].Resize(3, 1) = Application.Transpose(Dict.keys())           '= 부서명
         [g3].Resize(3, 1) = Application.Transpose(Dict.items())          '= 부서 총 매출
        
         rngAll.Copy [f7]
         Set rngAll = [f7].CurrentRegion                                  '= 부서내용 복사
    
         rngAll.Sort key1:=[f7], key2:=[g7], Header:=xlYes                '= 부서 / 성명 으로 정렬

    For Each key In DictN.keys                                            '= 부서명 만큼 순환
        For Each rngA In rngAll.Columns(1).Cells                          '= 부서 세부 매출 순환
        
            If key = rngA Then                                            '= 부서명과 부서 세부명이 같으면
                Application.DisplayAlerts = False
                    rngA.Resize(DictN(key), 1).Merge                      '= 병합
                Application.DisplayAlerts = True
                Exit For                                                  '= 다른 부서 병합을 위해 EXIT
            End If
            
        Next rngA
    Next key
    
    [a1:i22].SpecialCells(2).Borders.LineStyle = 2                        '= 라인정리
        
End Sub

본인과 같이 이 길을 가고 있는 그리고 가고 있을 분들께 나의 연구가 조금이라도 도움이 되길 바란다.

문제.xlsm

0.02MB