A macro that highlights what's different in a cell?

jonathynblythe

New member
Joined
Jul 5, 2011
Messages
13
Reaction score
0
Points
0
Hello again,

I thank everyone for all the help and coding you've done for me!

View attachment Example111.xlsm

I have attached a workbook. Anne Beal on sheet1 has a different address on sheet2 - I'm looking to have a macro that compares what's on sheet1 to sheet2. What I wanted to know was, how do I program a macro where ONLY the text of "470th" of Anne Beal's address on sheet1 is highlighted red, rather than the whole cell being highlighted red?

Thanks in advance!
JB
 
Code:
Public Sub ProcessData()
Dim cell As Range
Dim Lastrow As Long
Dim vecElements As Variant
Dim vecElements2 As Variant
Dim i As Long, j As Long

    Application.ScreenUpdating = False
    
    With Worksheets(1)
    
        Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
        For i = 1 To Lastrow
        
            On Error Resume Next
                Set cell = Worksheets(2).Columns(1).Find(.Cells(i, "A").Value2)
            On Error GoTo 0
            If Not cell Is Nothing Then
            
                If .Cells(i, "B").Value2 <> cell.Offset(0, 1).Value2 Then
                
                    vecElements = Split(.Cells(i, "B").Value2, " ")
                    vecElements2 = Split(cell.Offset(0, 1).Value2, " ")
                    For j = LBound(vecElements) To UBound(vecElements2)
                    
                        If vecElements(j) <> vecElements2(j) Then
                        
                            .Cells(i, "B").Characters(Application.Find(vecElements(j), .Cells(i, "B").Value2), Len(vecElements(j))).Font.ColorIndex = 3
                        End If
                    Next j
                End If
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub
 
Wow!!!! This is great!!! Thanks Bob Phillips!!!

Maybe just one last request with this code? :becky:

I have a code here from SHG over at excelforum.com and I was wondering how I can combine your code with his:

Code:
Sub FindMismatch()
    Dim rInp        As Range    ' input range
    Dim cellI       As Range    ' cell in rInp
 
    Dim r2F         As Range    ' Sheet2 col F
    Dim cellF       As Range    ' cell in col F
 
    Dim vi          As Variant  ' for/each variable
 
    Set rInp = Application.InputBox("Choose the first range", "Range 1", Type:=8)
    If rInp Is Nothing Then Exit Sub
 
    With Worksheets("Sheet2")
        Set r2F = .Range("F1", .Cells(.Rows.Count, "F").End(xlUp))
    End With
 
    For Each cellI In rInp
        Select Case WorksheetFunction.CountIf(r2F, "*" & cellI.Text & "*")
            Case 0
                cellI.Interior.ColorIndex = 5
            Case 1
                For Each vi In Array(-5, -4, -3, -2, -1, 1)
                    For Each cellF In r2F
                        If cellF.Value = cellI.Value And cellF.Offset(0, vi).Value <> cellI.Offset(0, vi).Value Then
                            cellI.Offset(0, vi).Interior.ColorIndex = 3
                        End If
                    Next cellF
                Next vi
        End Select
    Next cellI
End Sub

What this code does is compare both sheets to each other and highlights the cell red if it finds differences in the A B C D E and F columns. Is it possible that I can have it leveled down to this nice text-only-difference instead of the whole cell being red?

THANKS SO MUCH AGAIN!!!
JB
 
Code:
Public Sub ProcessData()
Dim cell As Range
Dim Lastrow As Long
Dim i As Long, j As Long

    Application.ScreenUpdating = False
    
    With Worksheets(1)
    
        Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
        For i = 1 To Lastrow
        
            On Error Resume Next
                Set cell = Worksheets(2).Columns(1).Find(.Cells(i, "A").Value2)
            On Error GoTo 0
            If Not cell Is Nothing Then
            
                Call CheckValues(Worksheets(1), i, 2, cell)
                Call CheckValues(Worksheets(1), i, 3, cell)
                Call CheckValues(Worksheets(1), i, 4, cell)
                Call CheckValues(Worksheets(1), i, 5, cell)
                Call CheckValues(Worksheets(1), i, 6, cell)
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

Private Function CheckValues( _
    ByRef sh As Worksheet, _
    ByVal ThisRow As Long, _
    ByVal ThisCol As Long, _
    ByRef MatchCell As Range)
Dim vecElements As Variant
Dim vecElements2 As Variant
Dim i As Long

    With sh.Cells(ThisRow, ThisCol)
    
        If .Value2 <> MatchCell.Offset(0, ThisCol - 1).Value2 Then
    
            vecElements = Split(.Value2, " ")
            vecElements2 = Split(MatchCell.Offset(0, ThisCol - 1).Value2, " ")
            For i = LBound(vecElements) To UBound(vecElements2)
            
                If vecElements(i) <> vecElements2(i) Then
                
                    .Characters(Application.Find(vecElements(i), .Value2), Len(vecElements(i))).Font.ColorIndex = 3
                End If
            Next i
        End If
    End With
End Function
 
I sincerely do thank you for all you've done for me here....

I just have one issue, when I try to use it, it tells me that the "subscript is out of range" and it keeps pointing to "If vecElements(i) <> vecElements2(i) Then".

Usually what I use is this:

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

This enables me to select what rows I want selected for sheet1 where it compares it to sheet2, starting with column F as you can see from the code above. I was wondering if it's possible to add this to the code where it might solve the problem?

Thank you again
JB
 
Try this

Code:
Public Sub ProcessData()
Dim Target As Range
Dim Lookup As Range
Dim cell As Range
Dim Lastrow As Long
Dim i As Long, j As Long

    Application.ScreenUpdating = False
    
    With Worksheets(1)
    
        Set Target = Application.InputBox("Choose the first range", "Range 1", Type:=8)
        If Not Target Is Nothing Then
        
            For Each Lookup In Target
        
                On Error Resume Next
                    Set cell = Worksheets(2).Columns(1).Find(Lookup.Value2)
                On Error GoTo 0
                If Not cell Is Nothing Then
                
                    Call CheckValues(Worksheets(1), Lookup.Row, 2, cell)
                    Call CheckValues(Worksheets(1), Lookup.Row, 3, cell)
                    Call CheckValues(Worksheets(1), Lookup.Row, 4, cell)
                    Call CheckValues(Worksheets(1), Lookup.Row, 5, cell)
                    Call CheckValues(Worksheets(1), Lookup.Row, 6, cell)
                End If
            Next Lookup
        End If
    End With
    
    Application.ScreenUpdating = True
End Sub

Private Function CheckValues( _
    ByRef sh As Worksheet, _
    ByVal ThisRow As Long, _
    ByVal ThisCol As Long, _
    ByRef MatchCell As Range)
Dim vecElements As Variant
Dim vecElements2 As Variant
Dim i As Long

    With sh.Cells(ThisRow, ThisCol)
    
        If .Value2 <> MatchCell.Offset(0, ThisCol - 1).Value2 Then
    
            vecElements = Split(.Value2, " ")
            vecElements2 = Split(MatchCell.Offset(0, ThisCol - 1).Value2, " ")
            For i = LBound(vecElements) To UBound(vecElements2)
            
                If vecElements(i) <> vecElements2(i) Then
                
                    .Characters(Application.Find(vecElements(i), .Value2), Len(vecElements(i))).Font.ColorIndex = 3
                End If
            Next i
        End If
    End With
End Function
 
Hmmm... I hate to bother you like this after all you've done for me here, but I'm still getting errors. The pop-up box will show up, but then the excel document in the background is this blue-colored box that can't be accessed when you try to select the range. If you type in the $f data into the box, it gives you a syntax error where it highlights that same line "vecElements" again... or it will highlight the "Private Function CheckValues( _" part.
 
Back
Top