Comparing two sheets data not found on third.

[rook123]

I am trying to capture changes for employees week to week.

Changes like New employees and changes in Address, Phone Numbers, emails...etc

My data is found A-H.

I am comparing a file every week. Sheet1 is the Master file, sheet2 is the weekly report that contains all the information on Sheet1 plus any new changes. The items not found on Sheet1 are then sent to Sheet3 as the CHANGES.


The code below is giving me the names not found on the master file and so those are the NEW employees.

What i need now is code that will also look at say column E, Column F etc...Even though an employee is existing they made changes to personal data. I need to have those employees also go to sheet3.

Any suggestions would be appreciated.

Sub NewTermsRpt()
Dim vDataOne, vDataTwo, vNotFound
Dim j As Long
Dim k As Long
Dim sSearch As String
Dim sData As String
With Sheets("Sheet1")
vDataOne = .Range("a1:h" & .Range("h65536").End(xlUp).Row)
End With
With Sheets("Sheet2")
vDataTwo = .Range("a1:h" & .Range("h65536").End(xlUp).Row)
End With
vNotFound = vDataTwo
For j = 1 To UBound(vDataTwo, 1)
sSearch = vDataTwo(j, 1) & vDataTwo(j, 2)
For k = 1 To UBound(vDataOne, 1)
sData = vDataOne(k, 1) & vDataOne(k, 2)
If InStr(sData, sSearch) Then
vNotFound(j, 1) = ""
vNotFound(j, 2) = ""
vNotFound(j, 3) = ""
vNotFound(j, 4) = ""
vNotFound(j, 5) = ""
vNotFound(j, 6) = ""
vNotFound(j, 7) = ""
vNotFound(j, 8) = ""
End If
Next k
Next j
With Sheets("sheet3")
.Activate
.Range(Cells(1, 1), Cells(UBound(vNotFound, 1), 8)).Select
Selection = vNotFound
Selection.Sort .Range("a1")
.Range("a1").Select
End With
End Sub

 

[rook123]

This Code here is really the Better option for what i want.

The only problem with this is that if on
John smith was on SHEET 1 on A1
and the next week
John smith is on SHEET 2 on A2

It thinks that is change.

It is not change, The name just is not located on A1 on both sheets, but it should not be a Change.

Is there a way to make the code below not do this?

If both names are in both sheets with the same information on all cells it is not a change, it just moved from one row to another?

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count > 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub

Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("MasterTermfile"), Worksheets("NewTermfile")
' compare two different worksheets in two different workbooks
CompareWorksheets ActiveWorkbook.Worksheets("MasterTermfile"), _
Workbooks("TERM MACRO.xls").Worksheets("NewTermfile")
End Sub