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

Chowhound
Comic Vine
GameFAQs
GameSpot
Giant Bomb
TechRepublic