Hi Dave,

I sent you the original macro so not to screw you up with my changes but in
the process - I think I've screwed up myself up and I'm confused- go figure.
I pasted my new program below based on all your past information that I've
integrated into it. I've cobbled it together and added a few additional
pieces such as modified ranges and changed workbook names.

The original code (minus the new "else" entry) does it's job just perfect.
However, after tweaking slightly and adding new "else" code - it still does
not work correctly. The No Match values from wkbkARng.Worksheets("Checklist
Log") do not write over to the Filename - next cell down under last entry.
The new "else" code actually does nothing and the only data the routine
brings over is the still just the match data and no new data is filled in for
the unmatched values.

I've included my macro with the revised names and added coding and maybe
this will help a bit more since I'm sure I'm a fault for trying to cobble in
data from the old routine.

Thank you again for your review - Roger


Sub fyCompare()
Dim Msg As String
Dim Path As String
Dim WkbkARng As Range
Dim myCell As Range
Dim res As Variant

On Error Resume Next
Application.ScreenUpdating = False
Msg = "Unable to find"
Path = "C:\Documents and Settings\Roger\Desktop\"
Filename = "PM Events.xls"

WkbkARng = ActiveWorkbook.Name
Err = 0

If WorkbookIsOpen(Filename) = False Then
Workbooks.Open Filename:=Path & Filename
Else
Workbooks(Filename).Activate
End If
If Err < 0 Then
MsgBox Msg & Path & Filename, vbCritical, "Error"
Exit Sub
End If

Set WkbkARng = Workbooks("Document Mgmt B55 Checklist
BETA.xls").Worksheets("Checklist Log").Range("E2:E100")
Set Filename = Workbooks("PM
Events.xls").Worksheets("Sheet1").Range("B2:B100")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, Filename, 0)
If IsError(res) Then

With Filename.Parent
.Cells(.Rows.Count, "b").End(xlDown).Offset(1, 0).Value =
myCell.Value
End With

'does not return unmatched values to next empty row in Filename
worksheet
Else

If Filename(res).Offset(0, 4).Value < "" Then

myCell.Offset(0, 1).Copy _
Destination:=Filename(res).Offset(0, -1)
myCell.Offset(0, -1).Copy _
Destination:=Filename(res).Offset(0, 1)
myCell.Offset(0, 3).Copy _
Destination:=Filename(res).Offset(0, 2)
myCell.Offset(0, 24).Copy _
Destination:=Filename(res).Offset(0, 4)
myCell.Offset(0, -3).Copy _
Destination:=Filename(res).Offset(0, 12)
myCell.Offset(0, 4).Copy _
Destination:=Filename(res).Offset(0, 13)
myCell.Offset(0, -2).Copy _
Destination:=Filename(res).Offset(0, 17)
myCell.Offset(0, 55).Copy _
Destination:=Filename(res).Offset(0, 18)

Else
End If
End If
Next myCell

ActiveWorkbook.Close savechanges:=True

Application.ScreenUpdating = True

End Sub

Private Function WorkbookIsOpen(wbName) As Boolean
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






"Roger" wrote:


Hi Dave,

Sorry to be a pain, but I have one last question.

In the macro you had helped me with, I tried to add an additional "else" in
the event no match is found. Basically, this program is set-up to look for
matches and write the data to the corresponding cells which works great.
However, I've been trying to add additional code( with no luck) to have it
step down to first empty cell in Sheet2 and write the unmatched value from
Sheet1 in the event no Match is found.

I tried using something along the lines -.end (x1down).row - plus what I've
noted in the Macro, but I've had no luck. The best I could do was to get it
to add multiple empty rows instead of adding just the one value for the
unmatched cell.

I appreciate your review and this should finally put this particular routine
to rest.

Thanks - Roger
__________________________________________________ ________________

Dim WkbkARng as range
dim WkbkBRng as range
dim myCell as range
dim res as variant 'could be a number or an error

set wkbkARng =
workbooks("workbookA.xls").worksheets("sheet1").ra nge("E2:e100")
set wkbkBRng =
workbooks("workbookB.xls").worksheets("sheet2").ra nge("a2:a100") << looking
for match in same row and column D to be < ""

for each mycell in wkbkarng.cells
res = application.match(mycell.value,wkbkbrng,0)
if iserror(res) then

If Not wkbkbrng(res).Offset(0, 4).Value < "" Then

............copy and write cells to offset of unmatchched value
to next empty cell......

<<<<tried adding irow here in event of no match - failed

else
mycell.offset(0,1).copy _
destination:=wkbkbrng(res).offset(0,1)

end if
next mycell