• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 616
  • Last Modified:

VBA Macro to find duplicates and copy rows

Hello,

I am trying to make a macro that checks the active sheet for duplicates in column C and if so copy the original and new rows with the duplicate fields to "seet2" and continue on.  I am having a bit of trouble getting it going mostly because of my lack of knowledge of the structure of the objects etc.

Here is what I have but is not working:

Sub Macro1()

    Dim ws, ws1 As Range
    Dim iMatches, iIsdup As Integer
    
    Set ws = Range("A1:Z3000")
    Set ws1 = Range("A1:Z3000")
    
    iMatches = 1
    
    For Each Row In ws.Rows
        If IsEmpty(ws.Cells(Row.Row, 1)) Then
            Exit For
        Else
            For Each row1 In ws1.Rows
                If IsEmpty(ws1.Cells(row1.Row, 1)) Then
                    Exit For
                Else
                    If ws1.Cells(row1.Row, 1).Value = ws.Cells(Row.Row, 1).Value Then
                        Worksheets("Sheet2").Rows(iMatches & ":" & iMatches) = row1
                        iMatches = iMatches + 1
                        iIsdup = 1
                    End If
                End If
            Next
        End If
    Next

End Sub

Open in new window


Any help is appreciated.  I know I am going about this all wrong programatically I am mostly trying to familiarize myself with the excel vba objects.  If this should be scrapped for a better approach then I am all ears.
0
jason987
Asked:
jason987
  • 6
  • 5
1 Solution
 
StephenJRCommented:
Could you perhaps post a small sample workbook so we can see if there might be a better approach?
0
 
jason987Author Commented:
Sure I colored in the cells that are being evaluated/duplicates:


Book1---Copy.xls
0
 
jason987Author Commented:
Sheet2 shows the desired output.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
StephenJRCommented:
Maybe this? In your example dog is also duplicated. Is it only if they are adjacent that they should be copied?
Sub x()

Dim r1 As Range, r2 As Range

With Sheet1
    Set r2 = .Range("C1", .Range("C1").End(xlDown))
    For Each r1 In r2
        If WorksheetFunction.CountIf(r2, r1) > 1 Then
            r1.Offset(, -2).Resize(, 4).Copy Sheet2.Range("A" & Rows.Count).End(xlUp)(2)
        End If
    Next r1
End With

End Sub

Open in new window

0
 
jason987Author Commented:
Arrggh dog should be copied/isduplicate too.
0
 
StephenJRCommented:
OK, well try the code on your example and it should work.
0
 
jason987Author Commented:
Your code returns true for the if statement but it doesn't seem to copy out the rows.
0
 
StephenJRCommented:
I tested it on your file and it worked.
0
 
jason987Author Commented:
Oops, my bad I had another workbook open that it was modifying.

Thanks for the code.  It works although, I was hoping to deal with the rows/values on a more individual basis.  Like I was hoping to manipulate the values by removing double spaces and redundant words.  I know how to do all of the string/value functions I am just a bit low on the knowledge of the kind of excel vba shorthand you have there.

0
 
jason987Author Commented:
Maybe it's just time for me to properly learn excel vba object model ;)
0
 
StephenJRCommented:
That sounds like a different question. You can use the Trim function to remove spaces, but you would have to specify what is redundant. But as I say, that is another question.
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

  • 6
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now