Compare Rows in Sheet 1 & Sheet2

[mhd143]

I need a bit of code please to compare rows in sheet1(columns B,C,D,E & G
only as column F is not consistant) against rows in sheet 2.

SHEET1
A B C D E F G
28 6/03/2006 24/03/2006 100.00% Holiday Fred Bloggs (Exists in
Sheet2))
29 20/02/2006 24/02/2006 100.00% Holiday Holiday John Smith (Exists in Sheet2)
30 24/02/2006 24/02/2006 100.00% Holiday Holiday Ian Brown (Does not exist
in Sheet2 as column G is different)


SHEET2
A B C D E F G
28 6/03/2006 24/03/2006 100.00% Holiday Holiday Fred Bloggs
29 20/02/2006 24/02/2006 100.00% Holiday Holiday John Smith
30 24/02/2006 24/02/2006 100.00% Holiday Holiday Ian Grey

If row exists in sheet2 i don't want to do anything BUT if row does not
exists i'd like to copy the row from sheet1 and paste it into the next
available row in Sheet2
Thanks
MHD143

 

[Tom Ogilvy]

Option Explicit

Sub ProcessData()
Dim rng1 As Range, rng2 As Range
Dim cell As Range, rw As Long
Dim cnt As Long, c As Range
Dim firstAddress As String
Dim i As Long
With Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
rw = rng2.Rows(rng2.Rows.Count).Row + 1
For Each cell In rng1
Set c = rng2.Find(cell, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
cnt = 0
For i = -2 To -6 Step -1
If cell.Offset(0, i) <> c.Offset(0, i) Then
Exit For
End If
cnt = cnt + 1
Next i
If cnt < 5 Then
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Set c = rng2.FindNext(c)
Loop While c.Address <> firstAddress
Else
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Next cell
End Sub

 

[Tom Ogilvy]

that first posting was flawed. Try this instead:

Option Explicit

Sub ProcessData()
Dim rng1 As Range, rng2 As Range
Dim cell As Range, rw As Long
Dim cnt As Long, c As Range
Dim firstAddress As String
Dim i As Long, bFound As Boolean
With Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
rw = rng2.Rows(rng2.Rows.Count).Row + 1
For Each cell In rng1
Set c = rng2.Find(cell, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
bFound = False
Do
cnt = 0
For i = -2 To -6 Step -1
If cell.Offset(0, i) <> c.Offset(0, i) Then
Exit For
End If
cnt = cnt + 1
Next i
If cnt = 5 Then
bFound = True
Exit Do
End If
Set c = rng2.FindNext(c)
Loop While c.Address <> firstAddress
If bFound = False Then
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Else
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Next cell
End Sub

 

[mhd143]

Thanks Tom

that first posting was flawed. Try this instead:

Option Explicit

Sub ProcessData()
Dim rng1 As Range, rng2 As Range
Dim cell As Range, rw As Long
Dim cnt As Long, c As Range
Dim firstAddress As String
Dim i As Long, bFound As Boolean
With Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, 7), _
.Cells(Rows.Count, 7).End(xlUp))
End With
rw = rng2.Rows(rng2.Rows.Count).Row + 1
For Each cell In rng1
Set c = rng2.Find(cell, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
bFound = False
Do
cnt = 0
For i = -2 To -6 Step -1
If cell.Offset(0, i) <> c.Offset(0, i) Then
Exit For
End If
cnt = cnt + 1
Next i
If cnt = 5 Then
bFound = True
Exit Do
End If
Set c = rng2.FindNext(c)
Loop While c.Address <> firstAddress
If bFound = False Then
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Else
cell.EntireRow.Copy _
Worksheets("sheet2").Cells(rw, 1)
rw = rw + 1
End If
Next cell
End Sub