Excel에서 중복 확인

Question

매크로에서 중복 된 셀을 식별하려고합니다. 중복을 식별하면 전체 행을 추출 할 수 있도록 매크로를 사용하려고합니다.

은이 코드를 사용 :

Sub MarkDuplicates() 
Dim iWarnColor As Integer 
Dim rng As Range 
Dim rngCell As Variant 


Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613") 
iWarnColor = xlThemeColorAccentz 

For Each rngCell In rng.Cells 
    vVal = rngCell.Text 
    If (WorksheetFunction.CountIf(rng, vVal) = 1) Then 
     rngCell.Interior.Pattern = xlNone 
    Else 
     rngCell.Interior.ColorIndex = iWarnColor 
    End If 
Next rngCell 
End Sub 

을하지만, 그것은 단지 빈 셀을 확인했다. 지금은 중복 된 텍스트 만 식별하려고하며 나중에 추출 할 것입니다.

도와 주시겠습니까?

Answer 1

당신은 rng.Cells를 넣을 필요가 없습니다 않음 - .Cells는 암시 - 단지 rng

를 사용합니다 (^ 이것은 의미입니다 - 당신이 원하는 무엇이든) 대신 rngCell.Text 확인의

을 - rngCell.Value을 시도합니다.

.Textis incredibly slow.

^정말,이에 따라, 아마 .Value2 대신 최대 speeeeeeed에 대한 .Value 사용해야합니다!

당연히 우리가 우려한다면 use a variant array이지만 간단하게 유지합시다. 당신이 xlThemeColorAccentz 및

이 작동 할 수 ColorIndex를 사용하는 이유 또한

는 나도 몰라,하지만 나를 위해 작동하지 않습니다 - 난 그냥 당신이 범위에 CountIf하고있는 RGB

을 사용 meh의 종류.

중복을 확인하는 경우 이 목적으로 dictionary을 사용하는 것이 좋습니다.

Dim dict As Object 
Set dict = CreateObject("Scripting.Dictionary") 

코드는된다 :

Sub MarkDuplicates() 
Dim iWarnColor As Long 
Dim rng As Range 
Dim rngCell As Variant 
Dim dict As Object 
Set dict = CreateObject("Scripting.Dictionary") 
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613") 

rng.Interior.ColorIndex = xlNone 'Optionally clear all coloring 
iWarnColor = RGB(230, 180, 180) 'Red 

For Each rngCell In rng 
    If rngCell.Value <> "" Then 'Ignore blank cells 
     If Not dict.Exists(rngCell.Value) Then 
      dict.Add rngCell.Value, rngCell.Row 'Store the row if we want 
     Else 
      rngCell.Interior.Color = iWarnColor 
      'Optionally color the original cell: 
      'Sheets("AllAccounts (12-05-2017)").Cells(dict(rngCell.Value), "D").Interior.Color = RGB(180, 230, 180) 
     End If 
    End If 
Next rngCell 
End Sub 

옵션 색칠 결과 :

편집 (사전을 사용하지 않음) : 그래서, 당신이있어

을 맥 오오 웰 사용 lz.

이전에는 언급하지 않았지만이를 해결하기 위해 조건부 서식을 사용할 수 있습니다.

어쨌든 컬렉션을 사용합시다.

컬렉션은 사전과 매우 유사하지만 일반적으로 특정 키/값 쌍이 존재하는지 여부를 결정하기 위해 루프를 반복해야합니다.

존재하지 않는 키 값을 얻고 오류를 잡으려고 시도하여이를 속일 수 있습니다.이 프로세스를 단순화하는 함수를 추가했습니다.

Sub MarkDuplicates() 
Dim iWarnColor As Long 
Dim rng As Range 
Dim rngCell As Variant 
Dim Col As New Collection 
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613") 
rng.Interior.ColorIndex = xlNone 
iWarnColor = RGB(230, 180, 180) 
For Each rngCell In rng 
    If rngCell.Value <> "" Then 'Ignore blank cells 
     If Not IsInCollection(Col, rngCell.Value2) Then 
      Col.Add rngCell.Row, Key:=rngCell.Value2 
     Else 
      rngCell.Interior.Color = iWarnColor 
      'Optionally color the original cell 
      Sheets("AllAccounts (12-05-2017)").Cells(Col(rngCell.Value2), "D").Interior.Color = RGB(180, 230, 180) 
     End If 
    End If 
Next rngCell 
End Sub 
Function IsInCollection(Col As Collection, Val As Variant) As Boolean 
    On Error Resume Next 
    Debug.Print (Col(Val)) 
    IsInCollection = (Err.Number = 0) 
    On Error GoTo 0 
End Function 

새로운 결과 (동일) :

Answer 2

나는이 작업을 수행하는 여러 가지 방법이 있습니다 가정합니다. 여기 하나 있습니다.

Option Explicit 

Sub FilterAndCopy() 

Dim wstSource As Worksheet, _ 
    wstOutput As Worksheet 
Dim rngMyData As Range, _ 
    helperRng As Range 

Set wstSource = Worksheets("Sheet1") 
Set wstOutput = Worksheets("Sheet2") 

Application.ScreenUpdating = False 

With wstSource 
    Set rngMyData = .Range("A1:XF" & .Range("A" & .Rows.Count).End(xlUp).Row) 
End With 
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1) 

With helperRng 
    .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)" 
    .Value = .Value 
    .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 
    .ClearContents 
End With 

Application.ScreenUpdating = True 

End Sub