Help: Sorting 2 columns according to matching cells, and fishing for duplicates

[mazin.j]

Hi everyone. This is my first post in these groups. Im a bit new to VBA

and I hope you can help.

I have been working on this macro for about three days. I can't seem to

figure out how to do this (primarily the part where it checks column A,

described below), and I have searched endlessly, but nothing fits what
Im looking for. I cannot download any add-ins, since my work network
security will not allow it.


I will try to explain this the best that I can (sorry for the long
explanation, but I want to be very clear).


I want it to:


- Read B1
- Read next row (B2)
- If next row (B2) = B1, then read next row (B3)
- Continue reading next row until cell does not = B1


- If next row does not = B1, then select the rows in column A that are
adjacent to all rows read in above steps (so if B1, B2, B3 and B4 are
all the same, then A1, A2, A3 and A4 should all be checked in the step
below)
- Check for any duplicates in these selected rows (there should be no
duplicates)
- If there are any duplicate cells in the rows checked in column A,
then all these rows (duplicate and non-duplicate) are to be selected
and copied into a new sheet (copy, not cut), and the original cells in
the original sheet are to be all highlighted yellow. Then proceed to
read the next cell in column B following the last read cell.
- If there are no duplicates, then it should proceed to read the next
cell in column B following the last read cell.
- NOTE: The above three steps should be ignored if no duplicates are
found in column B. In this case it should just move on to the next
cell.
- This should continue reading the next cell in B and looping the
process until it reaches a cell with the text "END" in it, where it
will end there.


Here is a visual example of what the sheet looks like (but it is about
8,000 to 10,000 rows down):


Column A Column B
Grostone 10D1
Grostone 10D3
Grostone 10D3
EXTx 10D3
PAP 10D3
PAP 10D4
PAP 10D9
PAP 10DE1A
PAP 10DE1B
PAP 10DE1C
PAP 10DE1D
END END


So, in this case, "10D1" is read and ignored since there are no
duplicates. "10D3" should be read four times (B2, B3, B4, B5), and so
lines A2, A3, A4 and A5 should be checked for duplicates. The two
"Grostone"s should be detected and so everything in lines 2, 3, 4 and 5

are copied and pasted into a new sheet (called "Duplicates"), and then
these lines (in original sheet) are all highlighted yellow. All other
cells are read in column B, and the macro terminates at the word "END".



I would greatly appreciate any help you can offer with this. Thanks in
advance.

 

[Dave Peterson]

So you group by column B and if there are any duplicates in column A for that
group, then the whole group is copied to a new report worksheet?

There's formula that's commonly posted in the newsgroups that counts unique
entries in a range:

=SUMPRODUCT((A1:A10<>"")/COUNTIF(A1:A10,A1:A10&""))

This code tries to figure out the top row of a group and the number of rows in
that group and then evaluates that formula for that range. If the number of
unique entries matches the number of rows in the group, then it doesn't do
anything. If the numbers are different, then those rows are copied over (and
shaded).

I assumed that you had headers in Row 1 and copied them over to the report
sheet. If you don't have headers in row 1, you can modify the code (yech!) or
you can just add them (yeah!).

You may want to try it against a slimmed down version of your data--just to see
if it works ok for you.

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim RptWks As Worksheet
Dim TopRow As Long
Dim BotRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim NumberInGroup As Long
Dim myFormula As String
Dim myAddr As String
Dim CountOfUniques As Long
Dim DestCell As Range

Set CurWks = Worksheets("sheet1")
Set RptWks = Worksheets.Add

'copy over the headerrows in row 1 to the report
CurWks.Rows(1).Copy _
Destination:=RptWks.Range("a1")

Set DestCell = RptWks.Range("a2")

With CurWks
'reset colors?
.Cells.Interior.ColorIndex = xlNone

FirstRow = 2 'headers in row 1??
'no need to put that "END" row in--just go through
'the last row with data in it in column B
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

'prime the pump
TopRow = FirstRow
BotRow = FirstRow
iRow = TopRow
Do
If .Cells(iRow, "B").Value = .Cells(iRow + 1, "B").Value Then
'another match in column B
'keep looking
Else
'irow is the last row in that group
BotRow = iRow
NumberInGroup = BotRow - TopRow + 1
If NumberInGroup = 1 Then
'only one entry in the group, so skip it
TopRow = TopRow + 1
BotRow = BotRow + 1
Else
'=SUMPRODUCT((A1:A10<>"")/COUNTIF(A1:A10,A1:A10&""))
myAddr = .Cells(TopRow, "A") _
.Resize(NumberInGroup, 1).Address(external:=True)
myFormula = "=sumproduct((" & myAddr & "<>"""")/COUNTIF(" _
& myAddr & "," & myAddr & "&""""))"
CountOfUniques = Application.Evaluate(myFormula)
If CountOfUniques = NumberInGroup Then
'no duplicates, do nothing
Else
.Rows(TopRow).Resize(NumberInGroup).Copy _
Destination:=DestCell
Set DestCell = DestCell.Offset(NumberInGroup)
.Rows(TopRow).Resize(NumberInGroup) _
.Interior.ColorIndex = 6
TopRow = BotRow + 1
BotRow = BotRow + 1
End If
End If
End If
iRow = iRow + 1
If iRow > LastRow + 1 Then
Exit Do
End If
Loop
End With

End Sub