Thank you for being a valued part of the CNET community. As of December 1, 2020, the forums are in read-only format. In early 2021, CNET Forums will no longer be available. We are grateful for the participation and advice you have provided to one another over the years.

Thanks,

CNET Support

General discussion

Need Help with Compare Macro

Oct 28, 2010 3:16AM PDT

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