[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 590
  • Last Modified:

VBA Excel compare sheet with highlight of the changed data

Hi,

I have found this code and done some minor changes to it, and would very much like to add a simple yet needed feature to it, when showing the changes in the sheet "Resultat" i would very much like to see which cell the changes is in with a highlighted colored cell, just like in conditional formating, how do i do this?

I'm sorry im very new to VBA and still learning

here is the code i'm using:

Private Sub CopyExceptionSheet_Click()

Dim r1 As Range, r2 As Range, r3 As Range

With Sheets("Data_in")
    Set r1 = .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Old_data")
    Set r2 = .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp))
End With

Sheets("Resultat").Range("1:" & Rows.Count).EntireRow.Delete
LastRow = 0
For Each r3 In r1
    Dim rng1 As Range
    Set rng1 = r2.Find(What:=r3.Value, After:=r2.Cells(1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False)
    If rng1 Is Nothing Then
       LastRow = LastRow + 1
       r3.EntireRow.Copy Sheets("Resultat").Range("A" & LastRow)
       'Sheets("Sheet3").Range("A" & LastRow).Value = r3.Value
    End If
Next r3

For Each r3 In r2
    Dim rng2 As Range
    Set rng2 = r1.Find(What:=r3.Value, After:=r1.Cells(1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False)
    If rng2 Is Nothing Then
       LastRow = LastRow + 1
       r3.EntireRow.Copy Sheets("Resultat").Range("A" & LastRow)
       'Sheets("Sheet3").Range("A" & LastRow).Value = r3.Value
    End If
Next r3

MsgBox "Samligning Kørt - se sheetet 'Resultat'"

End Sub

Open in new window

0
Hakum
Asked:
Hakum
1 Solution
 
Rgonzo1971Commented:
Hi,

pls try

Private Sub CopyExceptionSheet_Click()

Dim r1 As Range, r2 As Range, r3 As Range

With Sheets("Data_in")
    Set r1 = .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Old_data")
    Set r2 = .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp))
End With

Sheets("Resultat").Range("1:" & Rows.Count).EntireRow.Delete
LastRow = 0
For Each r3 In r1
    Dim rng1 As Range
    Set rng1 = r2.Find(What:=r3.Value, After:=r2.Cells(1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False)
    If rng1 Is Nothing Then
       LastRow = LastRow + 1
       r3.EntireRow.Copy Sheets("Resultat").Range("A" & LastRow)
       Sheets("Resultat").Cells(LastRow, r3.Column).Interior.Color = vbYellow
       'Sheets("Sheet3").Range("A" & LastRow).Value = r3.Value
    End If
Next r3

For Each r3 In r2
    Dim rng2 As Range
    Set rng2 = r1.Find(What:=r3.Value, After:=r1.Cells(1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False)
    If rng2 Is Nothing Then
       LastRow = LastRow + 1
       r3.EntireRow.Copy Sheets("Resultat").Range("A" & LastRow)
       Sheets("Resultat").Cells(LastRow, r3.Column).Interior.Color = vbYellow
       'Sheets("Sheet3").Range("A" & LastRow).Value = r3.Value
    End If
Next r3

MsgBox "Samligning Kørt - se sheetet 'Resultat'"

End Sub

Open in new window

Regards
0
 
HakumAuthor Commented:
Awesome!! thank you sooo much!!! it works like a charm :)
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

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