Results 1 to 7 of 7

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

  1. #1

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hello again,

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

    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

  2. #2
    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

  3. #3
    Wow!!!! This is great!!! Thanks Bob Phillips!!!

    Maybe just one last request with this code?

    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

  4. #4
    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

  5. #5
    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

  6. #6
    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

  7. #7
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •