[기초방] VBA 100제 #54 [ 색상그룹정렬 ]

색상그룹정렬하는 코드이다. 

 

사용한 코드는 오랜만에 컬렉션과 For each조합으로 풀어보았다.

Sub 기초방54_색상정렬하기()

    Dim Col As New Collection
    Dim Mycol
    Dim rngAll As Range: Set rngAll = Range([c4], [d4].End(4))
    Dim rngA As Range, rngS As Range
    Dim rngX As Range: Set rngX = [h4]
    Dim Cnt&
    
    For Each rngA In rngAll.Columns(2).Cells      '= 색상 추출
    
        On Error Resume Next                      '= 고유한 색상만 추출
        
            Col.Add rngA.Interior.Color, CStr(rngA.Interior.Color)
        
        On Error GoTo 0
    
    Next rngA
   
    For Each Mycol In Col                         '= 컬렉션 순환
        
        For Each rngA In rngAll.Columns(1).Cells  '= 전체영역 순환
        
            If rngA.Interior.Color = Mycol Then   '= 컬러와 바탕색이 같으면
                Cnt = Cnt + 1
                rngX.Resize(1, 2) = Array(rngA, rngA(1, 2))  '= 출력하고
                rngX.Resize(1, 2).Interior.Color = Mycol     '= 바탕색을 입혀라
                Set rngX = rngX.Offset(1)         '= 다음 행으로 이동
            
            End If
        
        Next rngA
        
        Set rngS = rngX.Offset(-Cnt).Resize(Cnt, 2)
        
        rngS.Sort rngX.Offset(-Cnt, 1), 2, Header:=xlNo     '= 같은 색상끼리 내림차순
        
        Cnt = 0
    
    Next Mycol
    
    [h4].CurrentRegion.Borders.LineStyle = 1

End Sub

Sub Haja_Remove()

    With Range([h4], [i4].End(4))
         .ClearContents
         .Borders.LineStyle = xlNone
         .Interior.Color = xlNone
    End With
    
End Sub

코드진행은 이렇다

1. 컬렉션으로 전체 영역의 고유 색상을 뽑아내고

2. 고유색상과 전체영역과 비교하여 해당값들을 기존 영역보다 하위에 자리잡게 하고

3. 동일 색상 그룹에서 정렬을 하는 코드이다.

 

물론 저번 시간처럼 application.match를 이용해도 되지만 좀 더 다양한 코드를 적용하고 싶어 For each문을 선택하였다.

 

색상별로 정렬하는 코드가 약간 어려울 수 있는데

Set rngS = rngX.Offset(-Cnt).Resize(Cnt, 2)
        
rngS.Sort rngX.Offset(-Cnt, 1), 2, Header:=xlNo  

Cnt = 0

내용은 rngX는 set rngX = rngX.offset(1)처럼 계속 다음 위치로 내려가기 때문에 cnt로 동일한 색상이 얼마나 있는지 카운팅 한 다음 색상 그룹이 종료되면 그 갯수를 파악해서 offset(-cnt).resize(cnt,2) 하면 동일 색상 그룹이 선택이 되게 된다.

 

그렇게 선택된 그룹들을 정렬하는 코드가 바로 위의 코드이다.

 

이 코드를 읽고 있을 누군가에게 응원을 보낸다.

 

기초방 54.xlsm

0.02MB