Help checking for duplicate numbers in VBA

[Tridiro]

Hello Everyone, I really need some help.

I need some code that will look through about 700 rows of numbers in a single column (range1) and see if that number already exist in another range of numbers(range2). If it does, i need it to copy that entire row to say sheet2, then resume checking the numbers where it left off until all duplicate numbers have been copied. this must be done in VBA.

The code below is just some test code, it dont work and i aint even close to getting it.

Sub test()
Dim MyRange As Range
Set MyRange = Range("B1:B20")
For Each cell In MyRange
    If cell.Value = Sheets("sheet2").Range("B1:B20").Value Then
        MsgBox ("value exist")
    Else
        MsgBox ("value does not exist")
    End If
Next
End Sub

 

[mirabeau]

Questions.

1. Are the numbers integers, current, or some type of code (like part numbers etc) with some test included? Positive, negative, zero, or all?

2. If decimals, say 5.3498567, how accurate do you want the match to be?

3. What is a duplicate number? Like if you have the number 7 occurring twice, is only one of these counted as duplicate, or are both duplicates?

 

[Trebor76]

Hi

Try this - just change the lines of code I've commented with 'Change to suit' to meet your needs:

Option Explicit
Sub Macro1()

    'http://www.mrexcel.com/forum/showthread.php?t=566169
    
    Dim objSource As Object, _
        objCompare As Object, _
        objOutput As Object
    
    Dim rngSource As Range, _
        rngCompareTo As Range, _
        rngCell As Range, _
        rngFoundCell As Range
        
    Dim lngRowPaste As Long
    
    Set objSource = Sheets("Sheet1") 'Source sheet name. Change to suit.
    Set objCompare = Sheets("Sheet2") 'Compare (to source) sheet name. Change to suit.
    Set objOutput = Sheets("Sheet3") 'Output for duplicates sheet name. Change to suit.
            
    Set rngSource = objSource.Range("B1:B20") 'Source range. Change to suit.
    Set rngCompareTo = objCompare.Range("B1:B20") 'Compare (to source) range. Change to suit.
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngSource
    
        If Len(rngCell) > 0 Then
        
            Set rngFoundCell = rngCompareTo.Find(What:=rngCell.Value, _
                                                LookIn:=xlFormulas, _
                                                LookAt:=xlWhole, _
                                                SearchOrder:=xlByRows, _
                                                SearchDirection:=xlNext, _
                                                MatchCase:=True, _
                                                SearchFormat:=False)
        
            'If the cell value is found on the compare range, then...
            If Not rngFoundCell Is Nothing Then
                '...copy the entire row to the next available row in the e in 'objOutput' tab.
                If WorksheetFunction.CountA(objOutput.Cells) = 0 Then
                    lngRowPaste = 1
                Else
                    lngRowPaste = objOutput.Cells.Find(What:="*", _
                                                          After:=[A1], _
                                                          SearchOrder:=xlByRows, _
                                                          SearchDirection:=xlPrevious).Row + 1
                End If
            
                objSource.Rows(rngCell.Row).Copy objOutput.Rows(lngRowPaste)
                            
            End If
            
        End If
        
    Next rngCell
    
    Application.ScreenUpdating = True
    
    If Not rngFoundCell Is Nothing Then
        MsgBox "All duplicates from " & objSource.Name & " have now been copied to " & objOutput.Name & ".", vbInformation, "Copy Duplicates Editor"
    Else
        MsgBox "All the enties in the range " & rngSource.Address & " for " & objSource.Name & " are unique.", vbExclamation, "Copy Duplicates Editor"
    End If
    
End Sub

HTH

Robert

 

[Tridiro]

The numbers are whole number and all have six digits (457894), all are positive numbers. no text. it is possible the the cell could be empty.

As far as the duplicate numbers, I actually typed that wrong. What i need is ...if the number is not duplicated in the range, I then need that entire row copied into a different sheet.

So... if row 22 has 457845 in column G, and it's nowhere in the second range, I need the entire row to be copied over and added to the the second range. it's basically updating a large table. i hope this makes sense.

 

[Trebor76]

For unique entry matching, try this:

Option Explicit
Sub CopyUnique()

    'http://www.mrexcel.com/forum/showthread.php?t=566169
    
    Dim objSource As Object, _
        objCompare As Object, _
        objOutput As Object
    
    Dim rngSource As Range, _
        rngCompareTo As Range, _
        rngCell As Range, _
        rngFoundCell As Range
        
    Dim lngRowPaste As Long
    
    Set objSource = Sheets("Sheet1") 'Source sheet name. Change to suit.
    Set objCompare = Sheets("Sheet2") 'Compare (to source) sheet name. Change to suit.
    Set objOutput = Sheets("Sheet3") 'Output for unique entries sheet name. Change to suit.
            
    Set rngSource = objSource.Range("B1:B20") 'Source range. Change to suit.
    Set rngCompareTo = objCompare.Range("B1:B20") 'Compare (to source) range. Change to suit.
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngSource
    
        If Len(rngCell) > 0 Then
        
            Set rngFoundCell = rngCompareTo.Find(What:=rngCell.Value, _
                                                LookIn:=xlFormulas, _
                                                LookAt:=xlWhole, _
                                                SearchOrder:=xlByRows, _
                                                SearchDirection:=xlNext, _
                                                MatchCase:=True, _
                                                SearchFormat:=False)
        
            'If the cell value is not found on the compared range, then...
            If rngFoundCell Is Nothing Then
                '...copy the entire row to the next available row in the e in 'objOutput' tab.
                If WorksheetFunction.CountA(objOutput.Cells) = 0 Then
                    lngRowPaste = 1
                Else
                    lngRowPaste = objOutput.Cells.Find(What:="*", _
                                                          After:=[A1], _
                                                          SearchOrder:=xlByRows, _
                                                          SearchDirection:=xlPrevious).Row + 1
                End If
            
                objSource.Rows(rngCell.Row).Copy objOutput.Rows(lngRowPaste)
                            
            End If
            
        End If
        
    Next rngCell
    
    Application.ScreenUpdating = True
    
    If rngFoundCell Is Nothing Then
        MsgBox "All unique entries from " & objSource.Name & " have now been copied to " & objOutput.Name & ".", vbInformation, "Copy Duplicates Editor"
    Else
        MsgBox "Every entry in the " & rngSource.Address & " range on the " & objSource.Name & " are duplicated in the " & objCompare.Name & " tab.", vbExclamation, "Copy Duplicates Editor"
    End If
    
End Sub

HTH

Robert

 

[Tridiro]

Awesome, thank you so much Trebor76

I'm at the point where I can read it and understand it, I'm able to modify most code for my usage, but... i have a lot of problem creating complex code with lots of variables.

Thanks Again

 

[Trebor76]

Thanks for the feedback and you're welcome. I'm gald MrExcel was able to provide you with a suitable solution