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

Question

Excel Macro that will do the following:
To Find All Duplicates in (ColumnA) and to see if (ColumnB) contains a certain value and run a code against that result.
How i would write the code if i could:
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.
^^sorry if not making sense up there:
I guess we can select first group of duplicates and run check on it like described below.^^
in this group all would be deleted, except one row.
(in this group we could specify to keep first "R-".value found and delete rest)
(this group has a "R-".value so the "M-".value gets deleted.)
(this group has a "R-".value so the "M-".value gets deleted.)
Code I used once to delete all "M-".value(s), hoping to reverse to do above as described per a first group found and to continue:
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
this code goes through column and finds duplicates and highlights them. Maybe this could be rewritten to highlight each duplicate a separate color?
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
this code Looks for colored cells a specific RGB color and selects them, maybe for each group that is colored differently select that color and do a function on it?
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
This has had me tied down to the computer for a week now and i cant seem to resolve it.

Answer 1

Here's an answer, it's a complicated one, but I took the question as a challenge to improve my use of particular methods in VBA.
This goes through your cells and creates an array of the results as you like.
I was using numbers in my testing, so every time you see str(Key) you might just need to remove the str() function.
This results in printing the array to columns D:E rather than removing rows from your list. You could just clear columns A:B and then print to "A1:B" & dict.Count - that would have the same effect, essentially.
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