Compare Multiple Columns in Multiple Sheets and Merge differences

[Robinsper]

I'm trying to compare the columns in two sheets for differences and similarities, using Column "B" as the reference to determine which records are the same and Column "F" to check if new changes were added to the current records. If some of the records in both columns are the same nothing happens but, if records in column "B" in sheet 1 and sheet 2 are the same and for the same row records in Column "F" are different between the 2 sheets then I need to copy the ones from sheet 2 and replace the ones in sheet 1.
I started working on the code but spent too much time sorting out the methods and watching tutorials, which landed me here asking for help, I'm attaching a sample of the document and the code that I was able to get so far, my problem is that I have it highlighting red to see if it finds what I'm asking for and it's doing it to everything.
Please help.


Option Explicit

Sub checkdifferences()

Dim LastPOcell As Integer

Dim LastAIRcell As Integer

Dim i As Integer

Dim j As Integer

LastPOcell = Cells(rows.Count, "B").End(xlUp).row

LastAIRcell = Cells(rows.Count, "F").End(xlUp).row

For j = 2 To LastAIRcell

For i = 2 To LastPOcell

If Sheets("Reversion").Cells(i, 2).Value = Sheets("Alpha").Cells(i, 2).Value & _

Sheets("Reversion").Cells(j, 2).Value <> Sheets("Alpha").Cells(j, 2).Value Then

Sheets("Alpha").Cells(i, 2).Font.Color = rgbRed

'Sheets("Alpha").Cells(i, 2).Copy

End If

Next i

Next j

End Sub



1839918400

[p45cal]

Sub checkdifferences()
Dim LastRevRow As Long
Dim LastAlphaRow As Long
Dim i As Integer
Dim j As Integer
LastRevRow = Sheets("Reversion").Cells(Rows.Count, "B").End(xlUp).Row
LastAlphaRow = Sheets("Alpha").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRevRow
For j = 2 To LastAlphaRow
If Sheets("Reversion").Cells(i, 2).Value = Sheets("Alpha").Cells(j, 2).Value And Sheets("Reversion").Cells(i, 6).Value <> Sheets("Alpha").Cells(j, 6).Value Then
Sheets("Alpha").Cells(j, 6).Font.Color = rgbRed
Sheets("Alpha").Cells(j, 6).Copy Sheets("Reversion").Cells(i, 6)
End If
Next j
Next i
End Sub
Will also overwrite data in Revision sheet if corresponding cell in Alpha sheet is blank

[Robinsper]

This is perfect! Thank you p45cal, you made my day :hi:.
Say, not to be a nagger or anything, I have about 3000 rows with about 20 columns in each sheet and it takes about a minute thirty to run this code, any suggestion as to how to make a bit faster.
Again, awesome work.

[p45cal]

Are there many blank cells in column 6 of Alpha that you could do without copying over?
Perhaps changing:
Sheets("Alpha").Cells(j, 6).Copy Sheets("Reversion").Cells(i, 6)
to:
Sheets("Reversion").Cells(i, 6).value=Sheets("Alpha").Cells(j, 6).value
but the red font won't get copied across.

[Robinsper]

I'm really sorry for the late reply, my uncle passed away and I had to put everything on hold to deal with that. I tried your suggestion bu it didn't do anything, it's still taking about two minutes to run to code. I don't have any blank cells in that column. Thanks for providing the answer though. Let's see if there's a way out of the long processing time :hi:

[p45cal]

Try adding:
Application.ScreenUpdating=False
at the top of the macro and:
Application.screenupdating=true
at the bottom.

Are the lots of formulae in the Reversion sheet?

[Robinsper]

I have no formulas in any of the sheets, I'll try your suggestion when I get home. Thanks again.

[Robinsper]

I tried turning off ScreenUpdating and nothing changed, I also tried "Application.Calculation = xlCalculationManual" at the beginning and Automatic at the end to no avail. I think the only way around it is by using collections instead of the loop or Range instead of the ".Cells" don't know if that'll even work or make a difference, let me know if I'm making any sense and if you think that'll increase performance. I was going to start trying it out, but I can't even think right now, it's 5am and I need to get some sleep. Thanks for keeping up with this challenge.
PS. Here's a picture of the last time I checked, with about 2400 rows in each sheet.

18427

[p45cal]

Test this and report on speed please:
Sub checkdifferences2()
Dim LastRevRow As Long, LastAlphaRow As Long, i As Long, j As Long
Dim RangeToUpdate As Range, SourceRng As Range, RevRngToColour As Range, AlphaRngToColour As Range

LastRevRow = Sheets("Reversion").Cells(Rows.Count, "B").End(xlUp).Row
LastAlphaRow = Sheets("Alpha").Cells(Rows.Count, "B").End(xlUp).Row

Set RangeToUpdate = Sheets("Reversion").Range("F2:F" & LastRevRow)
Set SourceRng = Sheets("Alpha").Range("F2:F" & LastAlphaRow)

RevPO = Sheets("Reversion").Range("B2:B" & LastRevRow).Value
AlphaPO = Sheets("Alpha").Range("B2:B" & LastAlphaRow).Value
RevAD = RangeToUpdate.Value
AlphaAD = SourceRng.Value

For i = 1 To UBound(RevPO)
For j = 1 To UBound(AlphaPO)
If RevPO(i, 1) = AlphaPO(j, 1) And RevAD(i, 1) <> AlphaAD(j, 1) Then
RevAD(i, 1) = AlphaAD(j, 1)
If RevRngToColour Is Nothing Then Set RevRngToColour = RangeToUpdate.Cells(i) Else Set RevRngToColour = Union(RevRngToColour, RangeToUpdate.Cells(i))
If AlphaRngToColour Is Nothing Then Set AlphaRngToColour = SourceRng.Cells(j) Else Set AlphaRngToColour = Union(AlphaRngToColour, SourceRng.Cells(j))
End If
Next j
Next i
If Not RevRngToColour Is Nothing Then
RangeToUpdate.Value = RevAD
RevRngToColour.Interior.Color = vbYellow
AlphaRngToColour.Interior.Color = vbYellow
End If
End Sub
If you want to change what's coloured and how, or want to remove it altogether, come back.

[snb]

@p45


Reduce the writing into the worksheet to once. (so avoid the set =range).

[p45cal]

As far as I know Set zzzz=Range… doesn't write anything to any sheet.
In the code there are only 3 writes to 2 sheets.
How would I reduce that to 1 write to each sheet without losing the colouring/highlighting?

[snb]

writing once:


Sub M_snb()
With CreateObject("scripting.dictionary")
For j = 1 To 2
sn = Sheets(Choose(j, "reversion", "alpha")).Cells(1).CurrentRegion
For jj = 2 To UBound(sn)
.Item(sn(jj, 2)) = Application.Index(sn, jj)
Next
Next

Sheets("reversion").Cells(20, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
End With
End Sub

NB. Union is a worksheet oriented method = Range
If the replacement is correct you don't need any colouring at all.

[Robinsper]

Sorry for showing up so late, but like I said in my last post I went to bed after 5am and I'm dealing with a death in the family. I just want to say thank you soooo much for being on top of this, especially to p45cal who stuck around even after he provided the answer to my original question. Not to turn this into a match or anything, but I checked the code from snb and p45cal just in case anyone else reads this thread and is trying to figure out what worked for my particular situation; snb's suggestion took about 1 minute 40 secs to execute and some of the cells were mixed up between columns, I'm pretty sure that it's probably something to do with my particular circunstance and not the structure of the code, so thank you for the help snb. That being said, p45cal latest suggestion was perfect, taking only around 3 seconds to execute and keeping the structure of the cells intact while updating the data in them, a big thank you p45cal I owe you big time, this solution will allow me to stop worrying about this problem and start thinking about the next one http://www.vbaexpress.com/forum/images/smilies/doh.gif. By the way, I don't need to copy the color from the Alpha sheet, however, I do need to color red the text that is copied over so I can tell what's changing over time since I have too many records to keep track of, so I just changed the interior color from vbYellow to vbRed. It all works the way I needed it to. Thanks again for the support and p45cal I hope I can pay it forward in the future.

1842918430

[p45cal]

p45cal latest suggestion <snip> taking only around 3 secondsExcellent! (I was going to do some time tests but you did them for me!)




By the way, I don't need to copy the color from the Alpha sheet, however, I do need to color red the text that is copied over so I can tell what's changing over time since I have too many records to keep track of.
Sub checkdifferences4()
Dim LastRevRow As Long, LastAlphaRow As Long, i As Long, j As Long
Dim RangeToUpdate As Range, SourceRng As Range, RevRngToColour As Range

LastRevRow = Sheets("Reversion").Cells(Rows.Count, "B").End(xlUp).Row
LastAlphaRow = Sheets("Alpha").Cells(Rows.Count, "B").End(xlUp).Row

Set RangeToUpdate = Sheets("Reversion").Range("F2:F" & LastRevRow)
Set SourceRng = Sheets("Alpha").Range("F2:F" & LastAlphaRow)

RevPO = Sheets("Reversion").Range("B2:B" & LastRevRow).Value
AlphaPO = Sheets("Alpha").Range("B2:B" & LastAlphaRow).Value
RevAD = RangeToUpdate.Value
AlphaAD = SourceRng.Value

For i = 1 To UBound(RevPO)
For j = 1 To UBound(AlphaPO)
If RevPO(i, 1) = AlphaPO(j, 1) And RevAD(i, 1) <> AlphaAD(j, 1) Then
RevAD(i, 1) = AlphaAD(j, 1)
If RevRngToColour Is Nothing Then Set RevRngToColour = RangeToUpdate.Cells(i) Else Set RevRngToColour = Union(RevRngToColour, RangeToUpdate.Cells(i))
End If
Next j
Next i
If Not RevRngToColour Is Nothing Then
RangeToUpdate.Value = RevAD
RevRngToColour.Font.Color = rgbRed
End If
End Sub

[Robinsper]

I edited my response to include an update, but thanks for posting the solution.

I just changed the interior color from vbYellow to vbRed. It all works the way I needed it to. Thanks again for the support and p45cal I hope I can pay it forward in the future.

[kvi24]

Hi,
A follow up question: How to compare and update multiple columns instead of just one (in the example col F)?

Help will be really appretiated.

Thanks

[snb]

Starting a new thread even more.