각 시트에서 중복된 연락처만 가져오기

한 시트에 다 불러서 한개만 있는 자료는 없애고

중복값 없애기 기능을 사용함

무식한 코딩의 좋은 예

Sub findDuplicate()
 
    Dim rnG As Range
    Dim rngPaste As Range
    Dim rngPhoneNumber As Range
    Dim i As Integer
 
    Application.ScreenUpdating = False
 
    '기존자료 삭제
    Range("A1").CurrentRegion.Offset(1).ClearContents
 
    '각 시트 순환하면서 날짜, 매체, 성별, 주소, 이름, 연락처, 내용을 sheet1에 가져옴
    For i = 1 To 3
        Set rngPaste = Cells(Rows.Count, "B").End(3)(2)
        With Sheets(i)
            .Range("B4", .Cells(Rows.Count, "H").End(3)).Copy rngPaste
        End With
    Next i
 
    '복사된 시트1에서 중복된 연락처만 골라내기
    Set rngPhoneNumber = Range("F2", Cells(Rows.Count, "F").End(3)).Offset(, 1)
    For i = Range("A1").CurrentRegion.Rows.Count To 2 Step -1
        With Cells(i, "G")
            If WorksheetFunction.CountIf(rngPhoneNumber, .Value2) <= 1 Then .EntireRow.Delete
        End With
    Next i
 
    '중복값 제거 후 열너비 맞춤
    With Range("A1").CurrentRegion
        .RemoveDuplicates Columns:=7, Header:=xlYes
        .Columns.AutoFit
    End With
 
    '순번 매기기
    i = 1
    Do While Cells(i + 1, "B") <> ""
        Cells(i + 1, "A") = i
        i = i + 1
    Loop
 
    Application.ScreenUpdating = True
End Sub

문의 및 상담고객 현황.xls