General discussion

Need Help with Compare Macro

The below macro does a good job with comparing an old vs a neew file and if all the columns but the last match, it adds the last column of data from the old file to the new file. However, I now need to compare the files with the exception of the last 2 columns of the old file and if they are the same then add the last 2 columns of the old file to the new.

Can't seem to be able to modify the below. Can anyone help?

Sub Copy_Comments()

Dim Oldwbk As Workbook, Newwbk As Workbook

Dim OldWbkName, NewWbkName

Dim Oldwks As Worksheet, Newwks As Worksheet

Dim Sheetname As String, FirstFindAddress As String

Dim CommentColumn As Long, Counter As Long

Dim Match As Boolean

Dim FindRange As Range, SourceRange As Range, CellRange As Range

OldWbkName = Application.GetOpenFilename("Microsoft Excel Files (*.xls), *.xls", , "Select the Listing With the Comments")

If OldWbkName <> False Then

Set Oldwbk = Workbooks.Open(OldWbkName)

End If

NewWbkName = Application.GetOpenFilename("Microsoft Excel Files (*.xls), *.xls", , "Select the new Listing")

If NewWbkName <> False Then

Set Newwbk = Workbooks.Open(NewWbkName)

End If

Application.ScreenUpdating = False

For Each Oldwks In Oldwbk.Worksheets

Sheetname = Oldwks.Name

On Error Resume Next

' Check same sheet exists in new workbook

Set Newwks = Newwbk.Worksheets(Sheetname)

If Not Newwks Is Nothing Then

CommentColumn = Oldwks.Range("IV1").End(xlToLeft).Column

Set SourceRange = Oldwks.Columns(CommentColumn).SpecialCells(xlCellTypeConstants)

For Each CellRange In SourceRange

Set FindRange = Newwks.Columns(1).Find(What:=Oldwks.Cells(CellRange.Row, 1), lookat:=xlWhole)

If Not FindRange Is Nothing Then

FirstFindAddress = FindRange.Address

Do

Match = True

For Counter = 1 To CommentColumn - 2

If FindRange.Offset(0, Counter) <> Oldwks.Cells(CellRange.Row, 1).Offset(0, Counter) Then

Match = False

Exit For

End If

Next Counter

If Match Then

Newwks.Cells(FindRange.Row, CommentColumn) = CellRange

End If

'Else

Set FindRange = Newwks.Columns(1).FindNext(FindRange)

'End If

Loop While FindRange.Address <> FirstFindAddress And Not FindRange Is Nothing

'Loop While Match = True And FindRange.Address <> FirstFindAddress And Not FindRange Is Nothing

End If

Next CellRange

End If

Next Oldwks

Newwbk.Save

Newwbk.Close

Oldwbk.Close False

Application.ScreenUpdating = True

Set Oldwks = Nothing

Set Newwks = Nothing

Set Newwbk = Nothing

Set Oldwbk = Nothing

End Sub

Discussion is locked

Follow
Reply to: Need Help with Compare Macro
PLEASE NOTE: Do not post advertisements, offensive materials, profanity, or personal attacks. Please remember to be considerate of other members. If you are new to the CNET Forums, please read our CNET Forums FAQ. All submitted content is subject to our Terms of Use.
Reporting: Need Help with Compare Macro
This post has been flagged and will be reviewed by our staff. Thank you for helping us maintain CNET's great community.
Sorry, there was a problem flagging this post. Please try again now or at a later time.
If you believe this post is offensive or violates the CNET Forums' Usage policies, you can report it below (this will not automatically remove the post). Once reported, our moderators will be notified and the post will be reviewed.
Comments

CNET Forums

Forum Info