Excel 宏，查找列中的所有重复项并查看对应值

Question

Excel 执行以下操作的宏：

查找 (ColumnA) 中的所有重复项并查看 (ColumnB) 是否包含特定值和运行针对该结果的代码。

如果可以我会怎么写代码：

If (ColumnB) .value in that (group of duplicates_found) in any row is "R-".value then

Keep the row with "R-".value and delete the rest. Else if "R-".value not exist and "M-".value Exist, delete all duplicates except first "R-".value found.

Else

If duplicate group contains "R-".value more than once, keep first "R-".value row found and delete the rest

Endif

Continue to loop until all duplicates found and run through above code.

^^抱歉，如果上面没有意义：我想我们可以 select 第一组重复项并运行如下所述检查它。^^

在这个组中，除一行外，所有内容都会被删除。

（在这个组中我们可以指定先保留"R-".找到的值并删除其余的）

（该组有一个 "R-".value，因此 "M-".value 被删除。）

我使用一次删除所有"M-".value(s)的代码，希望按照第一组的描述反向执行上述操作找到并继续：

Sub DeleteRowWithContents()
Dim rFnd As Range, dRng As Range, rFst As String, myList, ArrCnt As Long
myList = Array("M-")

    For ArrCnt = LBound(myList) To UBound(myList)
        With Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
            Set rFnd = .Find(What:=myList(ArrCnt), _
                             LookIn:=xlValues, _
                             LookAt:=xlPart, _
                             SearchOrder:=xlByRows, _
                             SearchDirection:=xlNext, _
                             MatchCase:=True)

            If Not rFnd Is Nothing Then

                rFst = rFnd.Address
                Do
                    If dRng Is Nothing Then
                        Set dRng = Range("A" & rFnd.Row)
                    Else
                        Set dRng = Union(dRng, Range("A" & rFnd.Row))
                    End If

                    Set rFnd = .FindNext(After:=rFnd)

                Loop Until rFnd.Address = rFst
            End If

            Set rFnd = Nothing
        End With
    Next ArrCnt

    If Not dRng Is Nothing Then dRng.EntireRow.Delete

End Sub

此代码遍历列并找到重复项并突出显示它们。也许这可以重写以突出显示每个重复的单独颜色？

Sub MarkDuplicates()

Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant


Range(Range("A2"), Range("A2").End(xlDown)).Select ' area to check '
Set rng = Selection
iWarnColor = xlThemeColorAccent2

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

此代码查找具有特定 RGB 颜色的彩色单元格并 select 对它们进行处理，也许对于每个颜色不同的组 select 该颜色并对其执行函数？

Sub SelectColoredCells()
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range

    'Select the color by name (8 possible)
    'vbBlack, vbBlue, vbGreen, vbCyan,
    'vbRed, vbMagenta, vbYellow, vbWhite
    lColor = RGB(156, 0, 6)

    'If you prefer, you can use the RGB function
    'to specify a color
    'Default was lColor = vbBlue
    'lColor = RGB(0, 0, 255)

    Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.Select
        MsgBox "Selected cells match the color:" & _
            vbCrLf & rColored.Address
    End If
    Set rCell = Nothing
    Set rColored = Nothing
End Sub

这已经让我被电脑束缚了一个星期了，我似乎无法解决它。

Answer 1

这是一个答案，它很复杂，但我把这个问题当作一个挑战来改进我在 VBA.

中对特定方法的使用

这会遍历您的单元格并根据您的喜好创建一个结果数组。

我在测试中使用了数字，所以每次看到 str(Key) 时，您可能只需要删除 str() 函数。

这会导致将数组打印到列 D:E 而不是从列表中删除行。您可以只清除列 A:B，然后打印到 "A1:B" & dict.Count - 本质上会产生相同的效果。

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

Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Dim strA As String

For i = 1 To lastrow
    strA = Cells(i, 1)
    dict(strA) = 1
Next

Dim vResult() As Variant
ReDim vResult(dict.Count - 1, 1)

Dim x As Integer
x = 0



Dim strB As String
Dim strKey As String

For Each Key In dict.keys
    vResult(x, 0) = Key
    x = x + 1
    For Each c In Range("A1:A" & lastrow)
        strA = Str(c)
        strB = c.Offset(0, 1).Value
          If strA = Str(Key) Then
            If Left(strB, 1) = "r" Then
                vResult(x - 1, 1) = c.Offset(, 1)
                GoTo label
            End If
           End If

    Next
    If vResult(x - 1, 1) = Empty Then
        For Each c In Range("A1:A" & lastrow)
            strA = Str(c)
            If strA = Str(Key) Then
                vResult(x - 1, 1) = c.Offset(, 1)
                GoTo label
            End If
        Next
    End If
label:
Next
Range("D1:E" & dict.Count).Value = vResult()
End Sub

Excel 宏，查找列中的所有重复项并查看对应值

Excel Macro, Find All Duplicates in Column and see coorisponding value

excel

vba

duplicates