Help Modifying Macro from Dave Peterson

[Jenny B.]

Hello Dave,

I try to look at past postings and modify existing macros before asking
questions, but I couldn’t get this one to work and was wondering if you could
help me since you originally helped this user set-up this application.

I’m looking to do something very similar to what this poster requested –
only just one portion. It appears this macro is matching two values from the
main sheet and pasting to a second sheet and then also pasting over the value
for just one column for the unmatched. That’s the portion I’m looking to
expand on – I really don’t need any values brought over for the matched cells.

I have two workbooks Master Reports and Location Reports. Basically the “If
IsError(res) Then†would be the portion I’d need code for and the only part
I’d like to modify. I’d like it to do the same thing meaning find next empty
row down in “D†and again write the value, but I’m looking to copy over the
entire unmatched row from Master Reports “Report Log†to that next down cell
starting with column “D†in Location Reports.

I tried to insert my sheets and columns in the code below and hopefully I
did in a way where you can tell what I’m looking for. I’ve also added notes
to the portion I’m looking to modify and hopefully this will provide a bit
further detail.

Thanks in advance – Jenny B.


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\Mine\Desktop\"
WkbkBName = "Location Reports.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("Master Reports.xlsâ€)
.Worksheets("Report Logâ€).Range("A2:A2000â€)
Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("A2:A2000â€)

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)

If IsError(res) Then

With WkbkBRng.Parent
.Cells(.Rows.Count, "dâ€).End(xlUp).Offset(1, 0).Value _
= myCell.Value
‘looking to have this copy over the value from Master Reports to Location
Reports
‘and copy the full row not just one cell
End With
Else
If WkbkBRng(res).Offset(0, 4).Value <> "" Then
myCell.Offset(0, 1).Copy _ ‘ don’t need this portion

End If
End If
Next myCell

wkbkb.ActiveWorkbook.Close savechanges:=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

 

[Dave Peterson]

First, if you look at your post, you'll see a bunch of funny characters in it.
I bet that they're caused by composing in MSWord, then copy|pasting to your
message.

This makes it more difficult to read and edit the code. You may want to use a
plain text editor (NotePad???) to make it easier for potential responders.

And maybe this untested, but compiled code is what you want:

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
Dim DestCell As Range

Msg = "Unable to find"
myPath = "C:\Documents and Settings\Mine\Desktop\"
WkbkBName = "Location Reports.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("Master Reports.xls") _
.Worksheets("Report Log").Range("A2:A2000")

Set WkbkBRng = WkbkB.Worksheets("Sheet1").Range("A2:A2000")

For Each myCell In WkbkARng.Cells
res = Application.Match(myCell.Value, WkbkBRng, 0)
If IsError(res) Then
'get ready to paste into Sheet1 at the bottom of column A
With WkbkBRng.Parent
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
myCell.EntireRow.Copy _
Destination:=DestCell
End With
End If
Next myCell

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

I did remove the .close (and save). I wasn't sure if you really wanted that.

 

[Jenny B.]

Hello Dave,

Thank you for the tip on my post. I was composing this in Outlook and
thought the offending party adding the symbols was after I pasted it in the
Disscussion Group Window - my error.

What you wrote works great, but is there any way to have it paste just the
values vs. the exact formatting on all the cells? I want the whole line of
data like now, but I'm just looking to paste over just the values since the
one sheet has different formatting then the other.

Thank you very much and appreciate your help - Jenny B.

 

[Dave Peterson]

myCell.EntireRow.Copy _

Destination:=DestCell
becomes

myCell.EntireRow.Copy
destcell.pastespecial paste:=xlpastevalues

 

[Jenny B.]

Thank you very much - works great!

 

[Gord Dibben]

How come I don't see any funny characters in Jenny's post?

I miss out on everything<g>

All I see are regular characters in her post and little hollow boxes when I add
CHAR(9)'s in a formula.


Gord

 

[Dave Peterson]

Maybe it's one of those Canadian fonts where nothing looks funny????

<gd&r>