Excel宏，在列中查找所有重复项并查看coorisponding值

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.

^^对不起，如果没有意义那里： 我想我们可以选择第一组重复项并运行检查，如下所述。^^

除了一行外，该组中的

都将被删除。

（在此群组中，我们可以指定保留第一个＆＃34; R - ＆＃34; .value找到并删除其余部分）

（此群组有一个＆＃34; R - ＆＃34; .value因此＆＃34; M - ＆＃34; .value会被删除。）

（此群组有一个＆＃34; R - ＆＃34; .value因此＆＃34; M - ＆＃34; .value会被删除。）

代码我使用 一次删除所有＆＃34; M - ＆＃34; .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颜色的彩色单元格并选择它们，可能对于每个颜色不同的组选择该颜色并对其执行功能？

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