VBA Code on how to compare the same range in two different sheets and display the result in third sh

Select Case Sh1Value Case Is = Sh2Value Sheets(3).Range("f2").Offset(X, Y).Value = 1 Case Is <> Sh2Value Sheets(3).Range("f2").Offset(X, Y).Value = -0.5 End Select X = X + 1

Dear Deborah,
Thanks for your reply. But there is actually a mistake on my previous message. Actually the program should do like this:-

For Each Cell in Range ("F2:IU30") in Book1(Sheet1) and Book2(Sheet1)
1) If the value of the cell in Book2(sheet1) in Range F2 equals to value in Book1(Sheet1) in Range F2 then return the value of 1 into the cell F2 in Book2(sheet2)
2) Else if the value of the cell in Book2(sheet1) in Range F2 not equal to value in Book1(Sheet1) in Range F2 then return the value of -0.5 into the cell F2 in Book2(sheet2)
3) Else if value in Book2(Sheet1) in Range F2 equals to " "(<blank cell>) then return the value of 0 into the cell F2 in Book2(sheet2).
4)Go to next range(Up until IU30)

Any idea?
Thanks in advance!

Here's the new code. Again, I'm sure someone else out there could write something a little cleaner but it works. I made a couple of assumptions. The code resides in one workbook. Then it opens the two workbooks you want to compare. If this is not the case let me know.

Also, I tried to write the code to be flexible in case the size of the range you are comparing changes size. Instead of the 'Do until = ""' you could do a 'For I = 1 to ?' if you know the number columns and rows will remain consistant. The way I wrote it though, it will work as long as the values in workbook 1 in the range being compared never has the value "" in it. It will work even if the size of the range being compared changes. The value "" indicates to the code that it is time to move to the next column or to stop comparing.

Hope this helps.
===============================
Option Explicit

Sub CompareSheets()

Dim X As Integer
Dim Y As Integer
Dim WB1 As String
Dim WB2 As String
Dim WB1Name As String
Dim WB2Name As String
Dim Value1
Dim Value2

WB1 = Application.GetOpenFilename
WB2 = Application.GetOpenFilename

X = 0
Y = 0

Workbooks.Open FileName:=WB1
WB1Name = ActiveWorkbook.Name
Workbooks.Open FileName:=WB2
WB2Name = ActiveWorkbook.Name

Value2 = Workbooks(WB2Name).Sheets(1).Range("f2").Offset(X, Y).Value
Value1 = Workbooks(WB1Name).Sheets(1).Range("f2").Offset(X, Y).Value

Do Until Value1 = ""

Do Until Value1 = ""

Select Case Value2
Case Is = ""
Workbooks(WB2Name).Sheets(2).Range("f2").Offset(X, Y).Value = 0
Case Is = Value1
Workbooks(WB2Name).Sheets(2).Range("f2").Offset(X, Y).Value = 1
Case Is &LT;&GT; Value1
Workbooks(WB2Name).Sheets(2).Range("f2").Offset(X, Y).Value = -0.5
End Select

X = X + 1

Value2 = Workbooks(WB2Name).Sheets(1).Range("f2").Offset(X, Y).Value
Value1 = Workbooks(WB1Name).Sheets(1).Range("f2").Offset(X, Y).Value

Loop

X = 0
Y = Y + 1

Value2 = Workbooks(WB2Name).Sheets(1).Range("f2").Offset(X, Y).Value
Value1 = Workbooks(WB1Name).Sheets(1).Range("f2").Offset(X, Y).Value

Loop

End Sub

aTuL,
Here is some masterful :) code. The only thing you will have to change is the path name and the 2 filenames. If the two workbooks are in different locations, you will have to add another path and name it path2. If you need help let me know. Hope it works like a charm, it did for me. You can also have the two workbooks close after the macro has run. Once again if you need help w/ that let me know. Let me know how it turns out!
Ryan

Sub Compare()
Dim Cell As Range
Dim Msg As String
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String

On Error Resume Next
Application.ScreenUpdating = False
Msg = "Unable to find "
Path = "C:\My Docs 3-00\"
FileName1 = "book1.xls"
FileName2 = "book2.xls"

If WorkbookIsOpen(FileName1) = False Then
Workbooks.Open FileName:=Path & FileName1
Else
Workbooks(FileName1).Activate
End If

If Err &LT;&GT; 0 Then
MsgBox Msg & Path & FileName2, vbCritical, "Error"
Exit Sub
End If

If WorkbookIsOpen(FileName2) = False Then
Workbooks.Open FileName:=Path & FileName2
Else
Workbooks(FileName2).Activate
End If

If Err &LT;&GT; 0 Then
MsgBox Msg & Path & FileName2, vbCritical, "Error"
Exit Sub
End If

For Each Cell In Range("F2:IU30")
If Workbooks(FileName1).Sheets("Sheet1").Range(Cell.Address).Text &LT;&GT; _
Workbooks(FileName2).Sheets("Sheet1").Range(Cell.Address).Text Then _
Workbooks(FileName2).Sheets("Sheet2").Range(Cell.Address).Value = -0.5
If Workbooks(FileName1).Sheets("Sheet1").Range(Cell.Address).Text = _
Workbooks(FileName2).Sheets("Sheet1").Range(Cell.Address).Text Then _
Workbooks(FileName2).Sheets("Sheet2").Range(Cell.Address).Value = 1
If Workbooks(FileName2).Sheets("Sheet1").Range(Cell.Address).Text = "" Then _
Workbooks(FileName2).Sheets("Sheet2").Range(Cell.Address).Value = 0

Next Cell
Application.ScreenUpdating = True
End Sub

Private Function WorkbookIsOpen(wbName) As Boolean
' Returns TRUE if the workbook is open
Dim X As Workbook
On Error Resume Next
Set X = Workbooks(wbName)
If Err = 0 Then WorkbookIsOpen = True _
Else: WorkbookIsOpen = False
On Error GoTo 0

End Function

Little Mistake

The first one of these:

If Err &LT;&GT; 0 Then
MsgBox Msg & Path & FileName2, vbCritical, "Error"
Exit Sub
End If

Should say FileName1, not 2. Sorry about that.
Ryan

I'm not exactly a VBA pro but the following code worked for me, assuming I understand your question. Feel free to contact me for more assistance. Good Luck!

Can someone please help me with my protect & share vba question I posted? Thanks!

Sub CompareSheets()

Dim X As Integer
Dim Y As Integer
Dim Sh1Value As Variant
Dim Sh2Value As Variant

X = 0
Y = 0

Do Until Sheets(1).Range("f2").Offset(X, Y).Value = ""

Do Until Sheets(1).Range("f2").Offset(X, Y).Value = ""

Sh1Value = Sheets(1).Range("f2").Offset(X, Y).Value
Sh2Value = Sheets(2).Range("f2").Offset(X, Y).Value

Select Case Sh1Value
Case Is = Sh2Value
Sheets(3).Range("f2").Offset(X, Y).Value = 1
Case Is &LT;&GT; Sh2Value
Sheets(3).Range("f2").Offset(X, Y).Value = -0.5
End Select

X = X + 1

Loop

X = 0
Y = Y + 1

Loop

End Sub