중복 항목에 채우기 후 삭제하기

안녕하세요.

 

자주 찾는 커뮤니티 사이트에 엑셀 관련 질문이 올라와 있었습니다.

 

www.clien.net/service/board/kin/16003781?od=T31&po=6&category=0&groupCd=community

엑셀에서 중복값 강조와 제거를 같이 할 수 있을까요? : 클리앙

이미 답글이 달려 있었고, VBA로 처리한 댓글도 있었습니다.

 

VBA 반복문으로 처리하는 작업입니다.

Sub 중복제거얍()

    Dim i As Double
    Dim j As Double
    Dim firstRow As Double
    Dim lastRow As Double
    Dim countIt As Double
    Dim tempStr As String
    
    lastRow = Range("A" & Rows.count).End(xlUp).Row
    [A:A].Sort [A2], 2, Header:=xlYes
    
    Range("b:b").ClearContents

    Do While Range("a1").Offset(j) <> ""
        
        If Range("a1").Offset(j) = Range("a1").Offset(j + 1) Then
            Range("a1").Offset(j).Interior.ColorIndex = 8
            tempStr = Range("a1").Offset(j)
            i = 1
            
            '중복개수세라 얍!
            Do While Range("a1").Offset(j + i) = tempStr
                countIt = countIt + 1
                i = i + 1
            Loop
            Range("b1").Offset(j) = countIt + 1
        Else
            Range("b1").Offset(j) = 1
        End If
        'For i = k To j + 1 Step -1
            'If Range("a" & i) = tempStr Then
                'Range("a" & i).EntireRow.Delete
                'Range("a" & j).Interior.ColorIndex = 8
            'End If
        'Next i
        j = j + 1 + countIt
        tempStr = ""
        countIt = 0
    Loop
    
    [A:B].Sort [B2], 2, Header:=xlYes
    firstRow = Range("B" & Rows.count).End(xlUp).Row
    
    Rows(firstRow + 1 & ":" & lastRow).EntireRow.Delete
    Range("b1") = "중복개수에용"
End Sub

 

엑셀 기능으로도 가능한 작업이라 매크로를 기록해 새로운 방법을 써 보았습니다.

 

엑셀 기능 중 COUNTIF 함수로 중복 항목 검사해 필터로 중복 항목에만 채우기 색을 적용하고 [중복된 항목 제거]로 삭제하도록 매크로를 작성했습니다.

Sub 중복()
'
' 중복 매크로
'

'
    Range("B1").Value = "중복"
    
    마지막행 = Range("A2").End(xlDown).Row
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Application.Goto Reference:="R2C2:R" & 마지막행 & "C2"
    Selection.FormulaR1C1 = "=COUNTIF(R2C1:R" & 마지막행 & "C1,RC[-1])"
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Application.CutCopyMode = False
    Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$B$" & 마지막행).AutoFilter Field:=2, Criteria1:=">1", _
        Operator:=xlAnd
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Interior.Color = 65535
        
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$B$" & 마지막행).RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

다양한 환경에서도 적용할 수 있도록 매크로를 조금 수정했습니다.

 

완성 파일 다운로드

중복제거샘플.xlsm

1.36MB

 

VBA 실행 속도는 위 반복문으로 처리한 것이 좀 더 빨랐습니다.

 

아래 매크로 기록으로 만든 코드도 좀 더 줄일 수 있을 테지만 많이 바꾸지 않았습니다.