A problem with duplication in Excel's macro

jonathynblythe

New member
Joined
Jul 5, 2011
Messages
13
Reaction score
0
Points
0
Hello and thank you for letting me into this forum!

I have a code that I just recently had modified and it looks like this:


Code:
Sub FindDuplicates2() 'matches against 2 cols
  Dim rng1 As Range
  Dim rng2 As Range
  Dim bMatch As Boolean
  Dim origRng As Range
  Dim compRng As Range
   
  On Error Resume Next
  Set origRng = Application.InputBox("Choose the first range", "Range 1", Type:=8)
      If origRng Is Nothing Then Exit Sub
  Set compRng = Application.InputBox("Choose the second range", "Range 2", Type:=8)
  'matches first cell in first range against each cell in second range
  'ranges do not need to be equal size
  'if there is a match then cell in second range turns green
  'if there is not a  match then cell in first range turns red
      For Each rng1 In origRng
          bMatch = False
          For Each rng2 In compRng
              If rng2.Text Like "*" & rng1.Text & "*" Then
                  bMatch = True
                  rng2.Interior.ColorIndex = 0
                      If rng2.Offset(0, -4).Value <> rng1.Offset(0, -4).Value Then
                          rng1.Offset(0, -4).Interior.ColorIndex = 3
                      
  End If
              End If
          Next rng2
              If bMatch = False Then
                  rng1.Interior.ColorIndex = 41
              End If
      Next rng1
       For Each rng1 In origRng
          bMatch = False
          For Each rng2 In compRng
              If rng2.Text Like "*" & rng1.Text & "*" Then
                  bMatch = True
                  rng2.Interior.ColorIndex = 0
                      If rng2.Offset(0, -5).Value <> rng1.Offset(0, -5).Value Then
                          rng1.Offset(0, -5).Interior.ColorIndex = 3
                      End If
              End If
          Next rng2
              If bMatch = False Then
                  rng1.Interior.ColorIndex = 41
              End If
      Next rng1
       For Each rng1 In origRng
          bMatch = False
          For Each rng2 In compRng
              If rng2.Text Like "*" & rng1.Text & "*" Then
                  bMatch = True
                  rng2.Interior.ColorIndex = 0
                      If rng2.Offset(0, -3).Value <> rng1.Offset(0, -3).Value Then
                          rng1.Offset(0, -3).Interior.ColorIndex = 3
                      End If
              End If
          Next rng2
              If bMatch = False Then
                  rng1.Interior.ColorIndex = 41
              End If
      Next rng1
       For Each rng1 In origRng
          bMatch = False
          For Each rng2 In compRng
              If rng2.Text Like "*" & rng1.Text & "*" Then
                  bMatch = True
                  rng2.Interior.ColorIndex = 0
                      If rng2.Offset(0, -1).Value <> rng1.Offset(0, -1).Value Then
                          rng1.Offset(0, -1).Interior.ColorIndex = 3
                      End If
              End If
          Next rng2
              If bMatch = False Then
                  rng1.Interior.ColorIndex = 41
              End If
      Next rng1
      
  End Sub

Now here's what I keep seeing when I check the numbers I want to check: image1.jpg

Now as you'll notice from the graphic above, the name Vicki Sikkink is highlighted red. The code posted above does that to show me that something is not matching with the other sheet... in this case, the name. All names with this code are compared through the phone numbers as their starting point.

Now here's the problem... this second sheet here is what it compared Vicki to:
Image2.jpg

As you can see from the first name on this sheet, the business "Intensive Hair Unit", it has the exact same phone number as Vicki (hence, this is her business). I didn't want the red highlight to highlight Vicki's name since as you can see from the bottom of the sheet, she is right down there also where her name matches what was on the first sheet (image1). What's happening is, this excel macro is assuming that since there is so much as one difference on that sheet with that number, the whole thing is wrong... where it doesn't even consider the fact that there is one that matches exactly.

How do I modify this code so that if it sees so much as one perfect match, then there will be no red highlight? It can disregard all the other differences if one matches. I'd like to add whatever the answer is to this to Leith's code that he gave me here too!

Thank you in advance!
JB
 
Hi JB,

I'm not sure I would want to modify the code, as I'm not sure you need so many loops in there. If this is a previous thread, can you point us in that direction so we're not double working this? From the sounds of it, and not knowing your data structure, I would recommend maybe a helper column, or at least an array of data to go from, then compare that one time, since you want to take the totality of the data, not cell-by-cell.
 
Hello,

Sorry, this isn't from an earlier thread on this website. I guess I should have mentioned that.

Yeah, I was wondering why this happens... it assumes that if two or more listings on the sheet do not match the first listing on the sheet number one where the phone numbers match, it figures the whole thing is wrong. All I need it to do is match one listing's data when the phone numbers match and that will suffice.

Thanks again!
JB
 
Is it possible to upload the file ?

Hello,

Sorry, this isn't from an earlier thread on this website. I guess I should have mentioned that.

Yeah, I was wondering why this happens... it assumes that if two or more listings on the sheet do not match the first listing on the sheet number one where the phone numbers match, it figures the whole thing is wrong. All I need it to do is match one listing's data when the phone numbers match and that will suffice.

Thanks again!
JB
 
It's hard to say what is what when we don't know what columns/rows of data you're looking at. You haven't given any kind of correlation to the pictures and the code supplied. I'm not really sure what is what range and what you're pointing us to. I understand your code, which is checking cell by cell, and is not doing any kind of overall check. If you can't upload a file, as vasantjob asked, at least describe (in detail) your worksheet ranges, as well as what ranges you're selecting for your original and comparative ranges.

Also, why do you need to select the ranges? Are they going to move? Are you going to only want to do portions a a time? Why not just keep it dynamic in the code and make the code find the ranges for you?
 
Hello guys, sorry I've been away but there was sort of an emergency for past week...

Unfortunately I'm not going to be allowed to upload an excel document with that data since it is sensitive information.

Also, why do you need to select the ranges? Are they going to move? Are you going to only want to do portions a a time? Why not just keep it dynamic in the code and make the code find the ranges for you?

Yes I do need to select ranges, they don't move but I don't need the whole document scanned - it has usally more than 45000 rows and that will take hours for data to be scanned that will not be needed on the sheet.

My question is, is there a way for the code (that I posted above) to ignore the address, name, zip code and city if so much as one phone number matches on both sheets where one phone number listing already matches one set of data with the other? If this makes sense?
 
Unfortunately I'm not going to be allowed to upload an excel document with that data since it is sensitive information.

Hi Jonathyn,

We're not actually after the data, what we're after is seeing the structure and patterns that it follows. If you can take your data and mock up something that fits the same patterns, it's all good for us. Start the first phone number at (123) 456-7890 and run it up 1 for each line from there. Find a list of baby names for the names in your file. Do whatever you have to do to the rest to make it random. (I'm sure 50 rows of data would be more than enough.) The key is that you should be able to demonstrate the issue with the data that you give us, then I'm sure things can be worked out.
 
You can give this a try if you wish although im not sure i grasped what it is you really want
Code:
'courtesy of Chip Pearson
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
                Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
            
End Function
Sub find_mismatch()
Dim MyMatch As Long, rFound
Dim Rng As Range, oRng As Range, MyCell As Range
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Set Rng = Sheets("Sheet1").Range("F1:F" & Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row)
Set oRng = Sheets("Sheet2").Range("F1:F" & Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row)
For Each MyCell In Rng
    If Application.WorksheetFunction.CountIfs(oRng, MyCell, oRng, MyCell.Offset(0, -5)) <> 0 Then
Set SearchRange = oRng
    FindWhat = MyCell
    Set FoundCells = FindAll(SearchRange:=SearchRange, _
                            FindWhat:=FindWhat, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)
    If FoundCells Is Nothing Then
        'Debug.Print "Value Not Found"
    Else
        For Each FoundCell In FoundCells
            FoundCell.Interior.ColorIndex = 3
        Next FoundCell
    End If
End If
Next MyCell
End Sub
 
I thank you much Simon for giving this code, however I tried it and I don't see it highlighting any numbers or anything else when I apply it. Is it perhaps missing some code?
 
Can you explain simply to me what you are expecting to see if i use your example?, is it, if an item found on sheet1 is not found in sheet2 then highlight it?
 
Yes, that's correct. If the phone number is missing from sheet2, even though it's on sheet1, then sheet1 notes that the phone number is missing by highlighting the cell blue (as per the code I originally posted). If it finds a match of phone numbers on both sheets, then it sees if the name, address, etc. also match. If they dont, each cell in that row (name, address, etc) gets a red highlight.

The problem was, if it finds duplicates, it assumes that different data on each phone number makes the red highlight legit... when all I need to know is one phone number's data on sheet1 does match the other sheet's phone number's data if the phone numbers are on both sheets... so that's there's no red highlight.
 
I think im confusing myself here so i've gone for a simpler approach for now, does this work?
Code:
Sub find_mismatch()
Dim MyMatch As Long, rFound
Dim Rng As Range, oRng As Range, MyCell As Range, oCell As Range, oRngOff As Range
Set Rng = Sheets("Sheet1").Range("F1:F" & Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row)
Set oRng = Sheets("Sheet2").Range("F1:F" & Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row)
Set oRngOff = Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row)
For Each MyCell In Rng
    If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
MyCell.Interior.ColorIndex = 5
ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) >= 1 Then
For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -5).Value <> MyCell.Offset(0, -5).Value Then
            oCell.Interior.ColorIndex = 3
    End If
Next oCell
End If
Next MyCell
End Sub
 
Hello Simon,

OH YES.... this does the trick. I was just wondering if I could add 2-4 more lines of code to what you've devised for me here.
I've slightly modified the code you wrote into this:

Code:
Sub find_mismatch()
  Dim MyMatch As Long, rFound
  Dim Rng As Range, oRng As Range, MyCell As Range, oCell As Range, oRngOff As Range
  Set Rng = Sheets("Sheet1").Range("F1:F" & Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row)
  Set oRng = Sheets("Sheet2").Range("F1:F" & Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row)
  Set oRngOff = Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row)
  For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -5).Value <> MyCell.Offset(0, -5).Value Then
            MyCell.Offset(0, -5).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
 End Sub
What this does is put the red highlighted cells on sheet 1 for me where we leave sheet 2 alone. What I was wondering was, can I put these additional lines of code in so I can select the ranges of cells for both sheets?



Code:
Set Rng = Application.InputBox("Choose the first range", "Range 1", Type:=8)
    If origRng Is Nothing Then Exit Sub
Set oRng = Application.InputBox("Choose the second range", "Range 2", Type:=8)

I don't know where this would go in the code that you made for me, so that's why I wondered.
One last thing, would it also be possible for me to have this line of code instead of an "exact equal" match?



Code:
If rng2.Text Like "*" & rng1.Text & "*" Then

What this does is eliminate "John" being incorrect in cell A whereas sheet 2 actually states "John and Mary". If it sees "John and Mary" using a regular equals sign, it makes it think that the cell is totally wrong, but this line of code here uses a wildcard option. Make sense?

Thank you so much again!
JB
 
******* UPDATE *********

Hey guys,

I just figured out how to insert the one line of code I wanted, plus I added more lines to look at other cells:

Code:
Sub Upper_Case()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Cell As Range
On Error Resume Next
For Each Cell In Cells.SpecialCells(xlConstants, xlTextValues)
Cell.Formula = UCase(Cell.Formula)
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub  
 
 
 
Sub find_mismatch()
  Dim MyMatch As Long, rFound
  Dim Rng As Range, oRng As Range, MyCell As Range, oCell As Range, oRngOff As Range
  Set Rng = Application.InputBox("Choose the first range", "Range 1", Type:=8)
    If Rng Is Nothing Then Exit Sub
  Set oRng = Sheets("Sheet1").Range("F1:F" & Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row)
  Set oRngOff = Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
  For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -5).Value <> MyCell.Offset(0, -5).Value Then
            MyCell.Offset(0, -5).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -4).Value <> MyCell.Offset(0, -4).Value Then
            MyCell.Offset(0, -4).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -3).Value <> MyCell.Offset(0, -3).Value Then
            MyCell.Offset(0, -3).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -2).Value <> MyCell.Offset(0, -2).Value Then
            MyCell.Offset(0, -2).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, -1).Value <> MyCell.Offset(0, -1).Value Then
            MyCell.Offset(0, -1).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
For Each MyCell In Rng
      If Application.WorksheetFunction.CountIf(oRng, MyCell) = 0 Then
  MyCell.Interior.ColorIndex = 5
 ElseIf Application.WorksheetFunction.CountIf(oRng, MyCell) <= 1 Then
 For Each oCell In oRng
If oCell = MyCell And oCell.Offset(0, 1).Value <> MyCell.Offset(0, 1).Value Then
            MyCell.Offset(0, 1).Interior.ColorIndex = 3
     End If
Next oCell
End If
Next MyCell
 End Sub

Now all I need to do is add that wildcard code that I posted in the last post, which I don't know how to do. Which is kind of why I came here to ask you guys :)

One other thing, perhaps this is asking for too much... but is there anyway a macro can tell me which words in a cell are different from the other sheet like this code here compares for me? If "123 anywhere st" is now "123 anywhere lane" on sheet two, is there any way that the text "st" can be highlighted red (key.color=3) rather than the whole cell? And to make it harder, can it find the closest match to sheet two and THEN show me what's different about the cell and highlight the text red? If that makes sense...

Thanks
 
Back
Top