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

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
with wrkbkbrng.parent 'sheet2 in workbookB.xls
.cells(.rows.count,"A").end(xlup).offset(1,0).valu e = mycell.value
end with
else
mycell.offset(0,1).copy _
destination:=wkbkbrng(res).offset(0,1)
end if
next mycell

----
I don't know if you want to change this line:
set wkbkBRng = workbooks("workbookB.xls").worksheets("sheet2").ra nge("a2:a100")
to
set wkbkBRng = workbooks("workbookB.xls").worksheets("sheet2").ra nge("a:a")

to include that new value in the next search.



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

--

Dave Peterson

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

I changed some of the variables, but I think the real problem was this line:

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

This starts at B65536 and tries to go down. And then tries to go down one more
row.

I used xlup so that I start at the bottom and work my way to the last used
cell. Then come down one (with the .offset(1,0) stuff).

..Cells(.Rows.Count, "b").End(xlup).Offset(1, 0).Value =

Anyway, this compiled, but I didn't test it:

Option Explicit
Sub fyCompare()
Dim Msg As String
Dim myPath As String
Dim WkbkARng As Range
Dim WkbkBRng As Range
Dim WkbkB As Workbook
Dim myCell As Range
Dim res As Variant
Dim WkbkBName As String

Msg = "Unable to find"
myPath = "C:\Documents and Settings\Roger\Desktop\"
WkbkBName = "PM Events.xls"

If WorkbookIsOpen(WkbkBName) = False Then
On Error Resume Next
Set WkbkB = Workbooks.Open(Filename:=myPath & WkbkBName)
If Err.Number < 0 Then
MsgBox Msg & myPath & WkbkBName, vbCritical, "Error"
Err.Clear
Exit Sub
End If
On Error GoTo 0
End If

Application.ScreenUpdating = False

Set WkbkARng = Workbooks("Document Mgmt B55 Checklist BETA.xls") _
.Worksheets("Checklist Log").Range("E2:E100")
Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("B2:B100")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)
If IsError(res) Then
With WkbkBRng.Parent
.Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Value _
= myCell.Value
End With
'does not return unmatched values to next empty row
'in WkbkBRng Worksheet
Else
If WkbkBRng(res).Offset(0, 4).Value < "" Then
myCell.Offset(0, 1).Copy _
Destination:=WkbkBRng(res).Offset(0, -1)
myCell.Offset(0, -1).Copy _
Destination:=WkbkBRng(res).Offset(0, 1)
myCell.Offset(0, 3).Copy _
Destination:=WkbkBRng(res).Offset(0, 2)
myCell.Offset(0, 24).Copy _
Destination:=WkbkBRng(res).Offset(0, 4)
myCell.Offset(0, -3).Copy _
Destination:=WkbkBRng(res).Offset(0, 12)
myCell.Offset(0, 4).Copy _
Destination:=WkbkBRng(res).Offset(0, 13)
myCell.Offset(0, -2).Copy _
Destination:=WkbkBRng(res).Offset(0, 17)
myCell.Offset(0, 55).Copy _
Destination:=WkbkBRng(res).Offset(0, 18)
End If
End If
Next myCell

'I'm not sure what workbook you're saving here.
'But I wouldn't use the Activeworkbook.
'I'd use WkbkArng.parent.parent or wkbkb.
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
End If
On Error GoTo 0
End Function



Roger wrote:

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

--

Dave Peterson

Hi Dave,

If I just paste in the whole code in place of mine, I get the message
"Object variable or with block variable not set". If I just paste in the
just the "else" into my existing version, it works but the "else" is now
copying all the cells from Column E Checklist Log to the Filename first empty
row vs. just the unmatched values.

Is there any way to modify this just a tad more to exclude the values that
are already matched? Since the original code doesn't replicate the cell
values that have a match (just uses match to identify rows that have Column E
and enters additional offset information), the unmatched differ due to they
would need that Column E data - but just the unmatched cells.

Is that at all a possibility?

Thanks again - Roger

"Dave Peterson" wrote:

I changed some of the variables, but I think the real problem was this line:

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

This starts at B65536 and tries to go down. And then tries to go down one more
row.

I used xlup so that I start at the bottom and work my way to the last used
cell. Then come down one (with the .offset(1,0) stuff).

..Cells(.Rows.Count, "b").End(xlup).Offset(1, 0).Value =

Anyway, this compiled, but I didn't test it:

Option Explicit
Sub fyCompare()
Dim Msg As String
Dim myPath As String
Dim WkbkARng As Range
Dim WkbkBRng As Range
Dim WkbkB As Workbook
Dim myCell As Range
Dim res As Variant
Dim WkbkBName As String

Msg = "Unable to find"
myPath = "C:\Documents and Settings\Roger\Desktop\"
WkbkBName = "PM Events.xls"

If WorkbookIsOpen(WkbkBName) = False Then
On Error Resume Next
Set WkbkB = Workbooks.Open(Filename:=myPath & WkbkBName)
If Err.Number < 0 Then
MsgBox Msg & myPath & WkbkBName, vbCritical, "Error"
Err.Clear
Exit Sub
End If
On Error GoTo 0
End If

Application.ScreenUpdating = False

Set WkbkARng = Workbooks("Document Mgmt B55 Checklist BETA.xls") _
.Worksheets("Checklist Log").Range("E2:E100")
Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("B2:B100")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)
If IsError(res) Then
With WkbkBRng.Parent
.Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Value _
= myCell.Value
End With
'does not return unmatched values to next empty row
'in WkbkBRng Worksheet
Else
If WkbkBRng(res).Offset(0, 4).Value < "" Then
myCell.Offset(0, 1).Copy _
Destination:=WkbkBRng(res).Offset(0, -1)
myCell.Offset(0, -1).Copy _
Destination:=WkbkBRng(res).Offset(0, 1)
myCell.Offset(0, 3).Copy _
Destination:=WkbkBRng(res).Offset(0, 2)
myCell.Offset(0, 24).Copy _
Destination:=WkbkBRng(res).Offset(0, 4)
myCell.Offset(0, -3).Copy _
Destination:=WkbkBRng(res).Offset(0, 12)
myCell.Offset(0, 4).Copy _
Destination:=WkbkBRng(res).Offset(0, 13)
myCell.Offset(0, -2).Copy _
Destination:=WkbkBRng(res).Offset(0, 17)
myCell.Offset(0, 55).Copy _
Destination:=WkbkBRng(res).Offset(0, 18)
End If
End If
Next myCell

'I'm not sure what workbook you're saving here.
'But I wouldn't use the Activeworkbook.
'I'd use WkbkArng.parent.parent or wkbkb.
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
End If
On Error GoTo 0
End Function



Roger wrote:

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

--

Dave Peterson

Hi Again Dave,

I found the error and now it's chugging right along.
With WkbkBRng.Parent - was listed as parent vs. With Filename.Parent. After
changing that, it writes the data over to the flawlessly and now both the
unmatched and matched are accounted for - thanks bunches.
Also thank you for the Active Workbook Tip. When I first set-up this
portion and tested it, it would not work if I listed Filename as the Workbook
I wanted closed. I had to resort to Active since that appeared to be the
only thing that worked. I'll now use your method and I'll also read up on
the whole "Parent" dynamic - not sure how that still functions.

Thank you so much for time. You truly have a knack for fixing up other
people's crappy codes.

Take care - Roger

"Roger" wrote:


Hi Dave,

If I just paste in the whole code in place of mine, I get the message
"Object variable or with block variable not set". If I just paste in the
just the "else" into my existing version, it works but the "else" is now
copying all the cells from Column E Checklist Log to the Filename first empty
row vs. just the unmatched values.

Is there any way to modify this just a tad more to exclude the values that
are already matched? Since the original code doesn't replicate the cell
values that have a match (just uses match to identify rows that have Column E
and enters additional offset information), the unmatched differ due to they
would need that Column E data - but just the unmatched cells.

Is that at all a possibility?

Thanks again - Roger

"Dave Peterson" wrote:

I changed some of the variables, but I think the real problem was this line:

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

This starts at B65536 and tries to go down. And then tries to go down one more
row.

I used xlup so that I start at the bottom and work my way to the last used
cell. Then come down one (with the .offset(1,0) stuff).

..Cells(.Rows.Count, "b").End(xlup).Offset(1, 0).Value =

Anyway, this compiled, but I didn't test it:

Option Explicit
Sub fyCompare()
Dim Msg As String
Dim myPath As String
Dim WkbkARng As Range
Dim WkbkBRng As Range
Dim WkbkB As Workbook
Dim myCell As Range
Dim res As Variant
Dim WkbkBName As String

Msg = "Unable to find"
myPath = "C:\Documents and Settings\Roger\Desktop\"
WkbkBName = "PM Events.xls"

If WorkbookIsOpen(WkbkBName) = False Then
On Error Resume Next
Set WkbkB = Workbooks.Open(Filename:=myPath & WkbkBName)
If Err.Number < 0 Then
MsgBox Msg & myPath & WkbkBName, vbCritical, "Error"
Err.Clear
Exit Sub
End If
On Error GoTo 0
End If

Application.ScreenUpdating = False

Set WkbkARng = Workbooks("Document Mgmt B55 Checklist BETA.xls") _
.Worksheets("Checklist Log").Range("E2:E100")
Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("B2:B100")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)
If IsError(res) Then
With WkbkBRng.Parent
.Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Value _
= myCell.Value
End With
'does not return unmatched values to next empty row
'in WkbkBRng Worksheet
Else
If WkbkBRng(res).Offset(0, 4).Value < "" Then
myCell.Offset(0, 1).Copy _
Destination:=WkbkBRng(res).Offset(0, -1)
myCell.Offset(0, -1).Copy _
Destination:=WkbkBRng(res).Offset(0, 1)
myCell.Offset(0, 3).Copy _
Destination:=WkbkBRng(res).Offset(0, 2)
myCell.Offset(0, 24).Copy _
Destination:=WkbkBRng(res).Offset(0, 4)
myCell.Offset(0, -3).Copy _
Destination:=WkbkBRng(res).Offset(0, 12)
myCell.Offset(0, 4).Copy _
Destination:=WkbkBRng(res).Offset(0, 13)
myCell.Offset(0, -2).Copy _
Destination:=WkbkBRng(res).Offset(0, 17)
myCell.Offset(0, 55).Copy _
Destination:=WkbkBRng(res).Offset(0, 18)
End If
End If
Next myCell

'I'm not sure what workbook you're saving here.
'But I wouldn't use the Activeworkbook.
'I'd use WkbkArng.parent.parent or wkbkb.
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
End If
On Error GoTo 0
End Function



Roger wrote:

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

--

Dave Peterson

A cell/range lives on a worksheet.

The range's parent is the worksheet it lives on.

The worksheet's parent is the workbook that contains that worksheet.

The workbook's parent is the Excel application itself.

So
wkbkBRng.parent
is the worksheet

wkbkbrng.parent.parent
is the workbook

Roger wrote:

Hi Again Dave,

I found the error and now it's chugging right along.
With WkbkBRng.Parent - was listed as parent vs. With Filename.Parent. After
changing that, it writes the data over to the flawlessly and now both the
unmatched and matched are accounted for - thanks bunches.
Also thank you for the Active Workbook Tip. When I first set-up this
portion and tested it, it would not work if I listed Filename as the Workbook
I wanted closed. I had to resort to Active since that appeared to be the
only thing that worked. I'll now use your method and I'll also read up on
the whole "Parent" dynamic - not sure how that still functions.

Thank you so much for time. You truly have a knack for fixing up other
people's crappy codes.

Take care - Roger

"Roger" wrote:


Hi Dave,

If I just paste in the whole code in place of mine, I get the message
"Object variable or with block variable not set". If I just paste in the
just the "else" into my existing version, it works but the "else" is now
copying all the cells from Column E Checklist Log to the Filename first empty
row vs. just the unmatched values.

Is there any way to modify this just a tad more to exclude the values that
are already matched? Since the original code doesn't replicate the cell
values that have a match (just uses match to identify rows that have Column E
and enters additional offset information), the unmatched differ due to they
would need that Column E data - but just the unmatched cells.

Is that at all a possibility?

Thanks again - Roger

"Dave Peterson" wrote:

I changed some of the variables, but I think the real problem was this line:

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

This starts at B65536 and tries to go down. And then tries to go down one more
row.

I used xlup so that I start at the bottom and work my way to the last used
cell. Then come down one (with the .offset(1,0) stuff).

..Cells(.Rows.Count, "b").End(xlup).Offset(1, 0).Value =

Anyway, this compiled, but I didn't test it:

Option Explicit
Sub fyCompare()
Dim Msg As String
Dim myPath As String
Dim WkbkARng As Range
Dim WkbkBRng As Range
Dim WkbkB As Workbook
Dim myCell As Range
Dim res As Variant
Dim WkbkBName As String

Msg = "Unable to find"
myPath = "C:\Documents and Settings\Roger\Desktop\"
WkbkBName = "PM Events.xls"

If WorkbookIsOpen(WkbkBName) = False Then
On Error Resume Next
Set WkbkB = Workbooks.Open(Filename:=myPath & WkbkBName)
If Err.Number < 0 Then
MsgBox Msg & myPath & WkbkBName, vbCritical, "Error"
Err.Clear
Exit Sub
End If
On Error GoTo 0
End If

Application.ScreenUpdating = False

Set WkbkARng = Workbooks("Document Mgmt B55 Checklist BETA.xls") _
.Worksheets("Checklist Log").Range("E2:E100")
Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("B2:B100")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)
If IsError(res) Then
With WkbkBRng.Parent
.Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Value _
= myCell.Value
End With
'does not return unmatched values to next empty row
'in WkbkBRng Worksheet
Else
If WkbkBRng(res).Offset(0, 4).Value < "" Then
myCell.Offset(0, 1).Copy _
Destination:=WkbkBRng(res).Offset(0, -1)
myCell.Offset(0, -1).Copy _
Destination:=WkbkBRng(res).Offset(0, 1)
myCell.Offset(0, 3).Copy _
Destination:=WkbkBRng(res).Offset(0, 2)
myCell.Offset(0, 24).Copy _
Destination:=WkbkBRng(res).Offset(0, 4)
myCell.Offset(0, -3).Copy _
Destination:=WkbkBRng(res).Offset(0, 12)
myCell.Offset(0, 4).Copy _
Destination:=WkbkBRng(res).Offset(0, 13)
myCell.Offset(0, -2).Copy _
Destination:=WkbkBRng(res).Offset(0, 17)
myCell.Offset(0, 55).Copy _
Destination:=WkbkBRng(res).Offset(0, 18)
End If
End If
Next myCell

'I'm not sure what workbook you're saving here.
'But I wouldn't use the Activeworkbook.
'I'd use WkbkArng.parent.parent or wkbkb.
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
End If
On Error GoTo 0
End Function



Roger wrote:

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

--

Dave Peterson


--

Dave Peterson