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.

^、これに基づいて、おそらく最大speeeeeeedため.Value2の代わり.Valueを使用する必要があります！

当然のことながら、私たちはuse a variant arrayですが、それを簡単にしましょう。また

、あなたはこれが働くかもしれないが、それは私のために動作しませんxlThemeColorAccentzとColorIndex

を使用する理由IDKの - 私はちょうどあなたがある範囲に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

私はこれを行うには、いくつかの方法があるとします。ここに1つあります。

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