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。

.Text is incredibly slow.

^实际上，基于此，应该使用.Value2代替.Value以获得最大值的人员！

当然，如果我们这样做，我们会use a variant array，但让我们保持简单。

另外，idk为什么使用xlThemeColorAccentz和ColorIndex

这可能有用，但它对我不起作用 - 我只会使用RGB

你在这个范围内做了CountIf。

至于检查副本，我建议为此目的使用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

可选着色的结果：

编辑（不使用字典）：

所以，你正在使用mac - 哦wellz。

之前我没有提到它，但你可以使用条件格式来解决这个问题。

无论如何，我们只是使用一个集合。

集合的工作方式很像字典，但我们通常需要遍历它以确定是否存在特定的键/值对。

我们可以通过尝试为不存在的密钥获取值并捕获错误来欺骗这一点 - 我添加了一个函数来简化此过程。

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

在Excel中识别重复项

2 个答案: