Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
Dave Peterson - last question
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Follow-up Question for Dave Peterson | Excel Discussion (Misc queries) | |||
Macro Question for Dave Peterson | Excel Discussion (Misc queries) | |||
Print question - Calling Dave Peterson! | Excel Discussion (Misc queries) | |||
Print question - Calling Dave Peterson! | Excel Discussion (Misc queries) | |||
Mr Dave peterson, Please help | Excel Discussion (Misc queries) |