Solved: Same cell address on different sheet comparison problems

[Phelony]

Hi Guys

I'm trying to fix a duplicated spreadsheet where users have been entering data into both, potentially for months.

We're working with the assumption that the original (sheet1 in the code below) is the correct and formal version, but have to import from the duplicate (sheet2 in the code below) any changes not reflected in the original.

The problem lies in the fact that the spreadsheet is not linear, in that there is not particular start or end date that could be used as a marker to determine where things went wrong as it is updated through a convoluted process. :banghead:

What I'm trying to do is write some code that can compare the two and take updates from sheet2 while preserving the existing data in sheet1. : pray2:

Sub seekanddestroy2()
'once the program has run and reached a predetermined ending point, it stops running
Do Until ActiveCell = Sheets("sheet1").Range("$A$10")
Loop
'if the active cell is in column G then go back to the first column
'of the next row
If ActiveCell.Address = Columns("G") Then
ActiveCell.Offset(1, -7).Select
Else
'if the active cell has the same content as the cell at the same address on
'sheet 2 then move to the next cell on the same row
If ActiveCell = Sheets("sheet2").ActiveCell.Address Then
ActiveCell.Offset(0, 1).Select
Else
'if the active cell does not have the same content as the same cell on
'sheet2 then copy across that data but add the date in and preserve the
'original entry
ActiveCell = ActiveCell & " - " & Chr(10) _
& Sheets("Sheet2").Range.ActiveCell.Address.Value & Chr(10) & Date & Chr(10)
Application.CutCopyMode = False
End If
End If
End Sub


I'm sure you've seen the activecell.address that I've used and winced as I'm sure I've got it wrong, but I don't know how else to get it to use the current cell location as a reference? :bug:

Basically, if anyone knows of a command or function that can be used to say:

Look at the cell on sheet X in the same location as the current active cell

I know it's an ugly piece of code, but if someone could give me a hand with finding the right function it would be greatly appreciated.:think:

Thanks

Phel x

[Bob Phillips]

myVal = Worksheet("X").Range(Activecell.Address).Value

[GTO]

Greetings Phelx,

Not sure, but if I read correctly, maybe try this in a toss away copy of your wb, case I goobered.

In a Standard Module:

Sub SeekAndDestroy_3()
Dim rCell As Range
Dim rRng As Range
Dim wksRetain As Worksheet
Dim wksToCheck As Worksheet
Const WKS_ORIG As String = "Sheet1" '<---CHange names to suit
Const WKS_COPY As String = "Sheet2"

'// It looked to me like this was the range we were interested in, //
'// leastwise by the example code. Rather than use the ActiveCell, //
'// I think we can grab it as an object and have better control. //
Set rRng = ThisWorkbook.Worksheets(WKS_ORIG).Range("A1:G10")

'// 'With' just to save my "type as fast as a seal" hands some //
'// keystrokes. //
With ThisWorkbook.Worksheets(WKS_COPY)
'// For ea cell in the important sheets range... //
For Each rCell In rRng
'// ... if that cell doesn''t equal the same cell on the //
'// other sheet... //
If Not rCell.Value = .Range(rCell.Address).Value Then
'// ...then we'll tack in the stuff we wanted. //
rCell.Value = rCell.Value & Chr(10) & .Range(rCell.Address).Value & _
Chr(10) & Format(Date, "MM/DD/YY")
End If
Next
End With
End Sub


Does that help?

Mark

[Phelony]

Absolutely outstanding Mark, does exactly what I was aiming at!!

I really need to start using dims more but I keep breaking them!

*runs off to do swotting up*

Thanks so much :clap:

Phel
x

[GTO]

:friends: Happy to help:thumb

[Phelony]

Little issue,

Could you help me with getting it to ignore blanks on the sheet2 part?

I've made an amendment to skip blanks, but it seems to have done more damage than good. It can be removed if it's going to cause an issue but I would really appreciate it if it were possible to ignore the blanks from sheet 2.

For Each rCell In rRng
'// ... if that cell doesn''t equal the same cell on the //
'// other sheet... //
If Not rCell.Value = .Range(rCell.Address).Value Then

'this is my entry to skip blanks
If Not rCell.Value = "" Then

'// ...then we'll tack in the stuff we wanted. //
rCell.Value = rCell.Value & Chr(10) & .Range(rCell.Address).Value & _
Chr(10) & Format(Date, "MM/DD/YY")


End If
End If

Thanks

Phel x

[GTO]

You could do it sort of like that, but two things:

You tested to see if rCell.Value was empty, which is the cell on Sheet1.
You need an End If included.Since we know we want it to pass BOTH tests (its different AND its not because the cell in sheet2 is empty) we could just add a test to the first IF.


Sub SeekAndDestroy_3()
Dim rCell As Range
Dim rRng As Range
Dim wksRetain As Worksheet
Dim wksToCheck As Worksheet
Const WKS_ORIG As String = "Sheet1" '<---CHange names to suit
Const WKS_COPY As String = "Sheet2"
'// It looked to me like this was the range we were interested in, //
'// leastwise by the example code. Rather than use the ActiveCell, //
'// I think we can grab it as an object and have better control. //
Set rRng = ThisWorkbook.Worksheets(WKS_ORIG).Range("A1:G10")

'// 'With' just to save my "type as fast as a seal" hands some //
'// keystrokes. //
With ThisWorkbook.Worksheets(WKS_COPY)
'// For ea cell in the important sheets range... //
For Each rCell In rRng
'// ... if that cell doesn''t equal the same cell on the //
'// other sheet... //
If Not rCell.Value = .Range(rCell.Address).Value _
And Not .Range(rCell.Address).Value = vbNullString Then
'// ...then we'll tack in the stuff we wanted. //
rCell.Value = rCell.Value & Chr(10) & .Range(rCell.Address).Value & _
Chr(10) & Format(Date, "MM/DD/YY")
End If
Next
End With
End Sub


Does that make sense?

Mark

[GTO]

ACK! My bad - I just spotted that you do have the End If in there. It just didn't line up in the window and I missed 'er.

[Phelony]

Darn it, so close and yet so far as usual!

I did try to get AND to work, but it wasn't playing ball. Although that's probably because the rest of it was bad an naughty code!

Thanks again Mark, superstar!! :cool:


Phelony
x