PDA

View Full Version : Compare, Match And Copy Data Row



hobbiton73
07-19-2013, 04:12 AM
Hi, I wonder whether someone may be able to help me please.

I'm trying to put together a script which compares two lists of data, and where a match is found, copy and paste the row of data into another sheet, to be more precise.

I have two open workbooks:


The first is called "Extracted Data" with the sheet "Extract".
The second is called "SIP" with the sheet called "Staff".
Each sheet contains a list of unique PID's in column B, starting at row 7. The "Extract" sheet can contain mutliple occurences of the same PID, whereas the "Staff" sheet will only have one occurence.
What I'd like to be able to is compare the list from the "Extract" sheet to the "Staff" sheet. If a match is found, I would then like to copy the row from the "Extract" sheet columns B:H and paste this into a sheet called "Completed", again, starting at row 7, contained within the same workbook as the "Extract" sheet.
I would like the macro to continue comparing the lists until it reaches a blank cell on the "Extract" sheet.

I've been researching this and I've found the following code:


Sub LookForDiscrepancies()
Dim varS1, varS2, varH1, varH2
Dim rngS1 As Range, rngS2 As Range
Dim c As Range, c1 As Range, c2 As Range
Dim iRow As Integer, iCol As Integer, i As Integer, iTest As Integer

Sheet1.Activate
Set rngS1 = Intersect(Sheet1.UsedRange, Columns("A"))
Sheet2.Activate
Set rngS2 = Intersect(Sheet2.UsedRange, Columns("A"))
Sheet3.Activate

Let iRow = iRow + 2
With rngS2
'Search for Sheet1 AU IDs on Sheet2
For Each c1 In rngS1
On Error Goto 0
Set c = .Find(what:=c1.Value) 'Look for match
If c Is Nothing Then 'Copy the AU ID to Sheet3
Sheet3.Cells(iRow, 1) = c1
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet1.UsedRange, c1.EntireRow)
Let varS2 = Intersect(Sheet2.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet1.UsedRange, c1.EntireRow).Count
Redim varH1(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH1(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 36
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With

Let iRow = iRow + 2
With rngS1
'Search for Sheet2 AU IDs on Sheet1
For Each c2 In rngS2
On Error Goto 0
Set c = .Find(what:=c2.Value) 'Look for match
If c Is Nothing Then 'Copy the AU ID to Sheet3
Sheet3.Cells(iRow, 1) = c2
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet2.UsedRange, c2.EntireRow)
Let varS2 = Intersect(Sheet1.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet2.UsedRange, c2.EntireRow).Count
Redim varH2(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH2(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH2(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 36
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
End Sub


The problem, I have is that I'm a little unsure about how to adapt this.

I just wondered whether someone could possibly look at this for me please and offer some guidance on how I may go about achieving this.

Many thanks and kind regards

SamT
07-19-2013, 06:24 AM
I understand "the problem." That's a good example of bad code that works.

Let's see if I understand your situation:


For each original PID in Staff
Find a matching PID in Extract
Resize Range matching PID to "B:H"
Copy matching PID to Completed, PasteRow 7
Increment PasteRow
Find Next matching PID
Loop Thru Extract PIDs until Not Found
Loop through Staff PIDs until DoneNow I have just two questions:

Are you pasting matching PIDs into Completed, Column "A" or "B"?

Do you still need help?

hobbiton73
07-19-2013, 08:38 AM
Hi @SamT,thank you for taking the time to reply to my post and my apologies for not being clear enough.

For each PID in "Extract"
Find a matching PID in "Staff"
When matched resize the row in "Extract" to columns B:H
Copy row
Paste row into "Completed", in column B starting at row 7
Increment paste row
Find Next matching PID
Loop through the "Extract" PIDs until Not Found
Loop through Staff PIDs until Done

Yes I would very much appreciate your help with this.

Many thanks and kind regards

Chris

SamT
07-19-2013, 11:45 AM
Chris,

With 165 posts, I imagine that you are learning VBA code, so I will break this down and only give the full code at the end of the post. I will also include some steps, (that could be combined,) just for clarity.

First we'll declare the Sub and all variables we think we might need. After we're done, we might have added or renamed some, and we might remove some.
Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim ECel As Range
Dim DiscrepancyFound As Range
Dim PasteCell As Range
Dim PasteRow As Long
Dim LastRow As Long

End Sub
A Code line to find the last used cell in a Column
LastRow = Range("B7").End(xlDown).Row
'This form is only used where Column B contains at least
'2 non-empty cells starting in row 7 and has contiguous cells down to the end

Code to set EpidRng, SpidRng and PasteCel. Uses Book and Sheet names to differentiate Range locations
LastRow = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = Workbooks("Extracted Data").Sheets("Extract").Range("B7:B" & LastRow)

LastRow = Workbooks("SIP").Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = Workbooks("SIP").Sheets("Staff").Range("B7:B" & LastRow)

Set PasteCel = Workbooks("Extracted Data").Sheets("Extract").Range("B7")
'Looks like we won't need PasteRow
The code to loop thru the PIDs on Extract sheet
For Each ECel in EpidRng
'Code to loop thru Staff PIDs goes here
Next ECelThat was hard :)

Code to loop thru the Staff PIDs. When I put the cursor (in VBA) in the word "Find" and pressed F1, I Saw that I have to check Cell Addresses to use it, so I'm adding a Variable to the list in the first Code example above.We are setting the first DiscrepancyFound outside the loop so that the pasting routine will never run without finding a matching PID.
Dim FirstFoundAddress As String
Set DiscrepanyFound = SpidRng.Find(Ecel)
FirstFoundAddress = DiscrepancyFound.Address

Do Until DiscrepancyFound = Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
DiscrepanyFound.Resize(0, 7) 'About 7: B counting to 7 = H where B is 1
'Paste code goes here
Set DiscrepancyFound = SpidRng.FindNext(ECel)
Loop
Now the code for pasting
DiscrepancyFound.Copy Destination:=PasteCel
Set PasteCel = PasteCel.Offset(1, 0)
If you have any questions about those code snippets, please ask.

Now we can put it all together.
OPtion Explicit

Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim ECel As Range
Dim DiscrepancyFound As Range
Dim PasteCell As Range
Dim LastRow As Long
Dim FirstFoundAddress As String

LastRow = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = Workbooks("Extracted Data").Sheets("Extract").Range("B7:B" & LastRow)

LastRow = Workbooks("SIP").Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = Workbooks("SIP").Sheets("Staff").Range("B7:B" & LastRow)

Set PasteCel = Workbooks("Extracted Data").Sheets("Extract").Range("B7")

For Each ECel in EpidRng
Set DiscrepanyFound = SpidRng.Find(Ecel)
FirstFoundAddress = DiscrepancyFound.Address

Do Until DiscrepancyFound = Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
DiscrepanyFound.Resize(0, 7) 'About 7: B counting to 7 = H where B is 1
DiscrepancyFound.Copy Destination:=PasteCel
Set PasteCel = PasteCel.Offset(1, 0)
Set DiscrepancyFound = SpidRng.FindNext(ECel)
Loop
Next ECel

End Sub

I wrote all the above in the VBAExpress post editor, so there could be mistakes, typos, and even code errors in it. :p:cuckoo::tease:

hobbiton73
07-20-2013, 06:37 AM
Hi @SamT, thank you very much for taking the time to put this together.

You are quite correct in that I am learning VBA so may I ask a couple of questions please.


I notice in the code that you use 'xldown' to find the last row, but I know from tutorials I've read and worked through that some have suggested using 'xlup'. Perhaps I've misunderstood, but could you tell me please, would 'xlup' still give the same result?



I realised that you used this line to resize the copy range: 'DiscrepanyFound.Resize(0, 7)' but could you tell me please could you also use the copy row command?


I've being looking at the code you kindly provided and unfortunately I'm unable to get this to work. There just seems to be a slight problem with this section :


Do Until DiscrepancyFound = Nothing

To be more precise, Debug highlights 'Nothing' as the issue and displays 'Compile error: Invalid Use Of Object'

Could you possibly tell me please where I may be going wrong?

Many thanks and kind regards

SamT
07-20-2013, 08:06 AM
LastRow is a widely used generic label that usually means "Row Number Of Bottom-Most Non-Empty Cell In A Column. (RNOBMNECIAC)

The comments explain the limitations/advantages of the various forms of LastRow.

RNOBMNECIAC:
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'This form is used when the entire column may be empty or,
'there may be empty cells above the bottom-most non-empty cell.
'This form must be used on a column that is known to always be the longest
'otherwise it may return a Row number that is above the bottom of the
'actual longest column
End(xlDown)

LastRow = Range("A1").End(xlDown).Row
'This form is used where the Column contains at least
'2 non-empty cells and has contiguous cells down to the end,
'or where one wants to find the next non-empty cell in a column containing values
'separated by empty cellsFor example; column "A" Rows, 1, 5, and 10 contain values. Starting this LastRow in "A1" will return Row number 5. If the column had values in Rows 1-3, 5-8, and 10-13. Starting in "A5" would return Row # 8. Restarting in "A8" would then return #10.

You can exactly simulate the actions of .End(xlUp, xlDown, xlToLeft, and xlTORight) by use of Ctrl+Arrow Key. On new sheet, place some values in random cells of Column ":A" and Row "1". Select a cell in "A" or "1" and press Ctrl+ an Arrow Key.


By deleting the .Row Property, LastRow becomes LastCell
LastCell = Range("A" & Rows.Count).End(xlUp)
You can use the .Address Property to convert LastRow to LastCellAddress
LastCellAddress = Range("C" & Rows.Count).End(xlUp).Address

This is Handy when you want to assign a multi-Cell Range to a variable
Set MyRange = Range("A1:" & Range("C" & Rows.Count).End(xlUp).Address) Assuming "C3" was the bottom cell, this would Set MyRange = Range("A1:C3")


Instead of Range("A" & Rows.Count) you can use Cells(Rows.Count, n) where n is the relevant Column Number. This is needed when you don't know which column will be used
n = Some code to return a column #
LastRowInColumnN = Cells(Rows.Count, n).End(xlUp).Row



I've being looking at the code you kindly provided and unfortunately I'm unable to get this to work. There just seems to be a slight problem with this section :

'If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do

DiscrepanyFound.Resize(0, 7) 'About 7: B counting to 7 = H where B is 1'
Try this
Set DiscrepancyFound = DiscrepancyFound.Resize(0, 7)
Be sure and put "Option Explicit" (without quotes) at the top of your code pages.

While the cursor is inside the sub, press F8 to step thru the running code one line at a time.

Using VBA menu >> Debug >> Compile will also find errors for you.

hobbiton73
07-20-2013, 08:28 AM
Hi @SamT, thank you very much for the guidance, very interesting.

I've tried the amended line so the section in question is as follows:


Do Until DiscrepancyFound = Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
Set DiscrepancyFound = DiscrepancyFound.Resize(0, 7)
'About 7: B counting to 7 = H where B is 1
DiscrepancyFound.Copy Destination:=PasteCell
Set PasteCell = PasteCell.Offset(1, 0)
Set DiscrepancyFound = SpidRng.FindNext(ECel)


Unfortunately though, I'm still receiving the same error?

Many thanks and kindest regards

Chris

SamT
07-20-2013, 01:15 PM
YOu changed.

Do While Not DisrecepancyFound is nothing

hobbiton73
07-21-2013, 06:23 AM
Hi @SamT, thank you very much for your continued help with this and for the fix.

I did look back at the original code you provided, and I couldn't see the line in question as:


Do While Not DisrecepancyFound is nothing

But my eyes may very well be playing tricks on me :)

Using the 'Compile' function you highlighted in one of our earlier exchanges, I've made the necessary changes and can now run the code without 'Compile' errors.

The problem I now is when I run the code, I receive the following error:

Run time error '9': Subscript out of range' and Debug highlights this rows as the issue:


LastRow = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row

Now I know that this error is normally something to do with the misspelling of sheet or workbook names, or the workbooks or sheets don't exist, but I've spent the last hour trying to find the problem and there doesn't seem to be any immediate problem.

I'm using Excel 2013, so I'm not sure whether this is the cause of the problem.

I really am very sorry to trouble you again, but could you possible look at the attached file to see if I've missed anything?

For completeness, please find my full script below:


Option Explicit

Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim ECell As Range
Dim DiscrepancyFound As Range
Dim PasteCell As Range
Dim LastRow As Long
Dim FirstFoundAddress As String

LastRow = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = Workbooks("Extracted Data").Sheets("Extract").Range("B7:B" & LastRow)

LastRow = Workbooks("SIP").Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = Workbooks("SIP").Sheets("Staff").Range("B7:B" & LastRow)

Set PasteCell = Workbooks("Extracted Data").Sheets("Extract").Range("B7")

For Each ECell In EpidRng
Set DiscrepancyFound = SpidRng.Find(ECell)
FirstFoundAddress = DiscrepancyFound.Address

' Do Until DiscrepancyFound = Nothing
Do While Not DiscrepancyFound Is Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
Set DiscrepancyFound = DiscrepancyFound.Resize(0, 7)
DiscrepancyFound.Copy Destination:=PasteCell
Set PasteCell = PasteCell.Offset(1, 0)
Set DiscrepancyFound = SpidRng.FindNext(ECell)
Loop
Next ECell

End Sub

Many thanks and kind regards

SamT
07-21-2013, 07:57 AM
No trouble. I get pleasure doing this. Not your eyes, my bad communication skills, which you overcame. Declaring LastRow as an integer can cause "Out of Range" if the last row number is larger than 32K, but that's not the case here. The code above should be in either, the ThisWorkbook module or a standard Module of a workbook that is open, and workbooks named in the code must be open. [The default variable type is Variant, which can handle anything, but takes a lot of memory and CPU cycles. "Dim X" declares "X" as a variant.] Temporarily insert this code above the problem line.
Dim X X = Workbooks("Extracted Data").Name X = Workbooks("Extracted Data").Sheets("Extract").Name X = Workbooks("Extracted Data").Sheets("Extract").Range("B7").Value X = Workbooks("Extracted Data").Sheets("Extract").Cells(Rows.Count, 2).End(xlUp).Row X = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row Press F8 to run the code one line at a time while hovering the cursor over one of the "X"es. Not that the highlighted line hasn't run yet. It's the next one.

SamT
07-21-2013, 08:05 AM
Gah! What a mess of a post. I experienced a wonderful microsoft update last night and it killed FireFox. I gotta reboot, then I'll fix that post.

hobbiton73
07-21-2013, 08:08 AM
Hi @SamT, thank you for being so understanding.

I've tried to implement the line you suggested but I'm receiving a 'Compile error: syntax error?

Incidentally, since posting my last comment I've continued to work on this, and if I change this line:

LastRow = Workbooks("Extracted Data").Sheets("Extract").Range("B7").End(xlDown).Row

to

LastRow = ActiveWorkbook.Sheets("Extract").Range("B7").End(xlDown).Row

The Subscript error disappears.

Many thanks and kind regards

SamT
07-21-2013, 08:16 AM
That "Line" of code is actually several lines, but my computor is fubar and all carriage returns are missing. If you put a CR in front of every "X=" it should be apparent what I suggested. anyway, I'm glad you got it working

hobbiton73
07-21-2013, 08:32 AM
Hi @SamT.

Thank you very much for the update.

To confirm I'm unable to get the code working.

Although I can use 'ActiveWorkbook' for the first workbook i.e. "Extracted Data", I cannot do the same for the "SIP" workbook, which gives the same 'Run time error '9': Subscript out of range' error. In this case highlighting the next row i.e.


LastRow = Workbooks("SIP").Sheets("Staff").Range("B7").End(xlDown).Row

Many thanks and kind regards

Chris

hobbiton73
07-21-2013, 10:26 AM
Hi @SamT.

After quite a bit more work and some 'Googling' I've managed to get the script to run without any errors. The code is as below:


Option Explicit
Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim ECell As Range
Dim DiscrepancyFound As Range
Dim PasteCell As Range
Dim LastRow As Long
Dim FirstFoundAddress As String

LastRow = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7:B" & LastRow)

LastRow = Workbooks("SIP.xlsm").Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = Workbooks("SIP.xlsm").Sheets("Staff").Range("B7:B" & LastRow)

Set PasteCell = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7")

For Each ECell In EpidRng
Set DiscrepancyFound = SpidRng.Find(ECell)
FirstFoundAddress = DiscrepancyFound.Address

' Do Until DiscrepancyFound = Nothing
Do While Not DiscrepancyFound Is Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
Set DiscrepancyFound = DiscrepancyFound.Resize(0, 7)
DiscrepancyFound.Copy Destination:=PasteCell
Set PasteCell = PasteCell.Offset(1, 0)
Set DiscrepancyFound = SpidRng.FindNext(ECell)
Loop
Next ECell

End Sub


However, although the macros runs, it doesn't paste the information into the "Completed" sheet.

I'm very sorry to trouble you but could you possibly take a look at this please and perhaps let me know where I'm going wrong?

Many thanks and kind regards

SamT
07-21-2013, 11:33 AM
What Worksheet did you use to set PasteCell? Look below.
Set PasteCell = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7") Change "Extract" to "Completed"

hobbiton73
07-21-2013, 10:40 PM
Hi @SamT, thank you very much for your continued help with this, it is greatly appreciated.I've amended the line as you suggested, but unfortunately I'm still unable to get the script to wor, I'm very sorry!There seems to be two issues:

If I have more than one ID on the "Extract" sheet the macro doesn't run and I don't receive an error message.



If I then remove all but one ID on the "Extract" sheet, the macro runs, but I receive the following error:'Run-time error '91': Object variable or With Block variable not set' and the Debug highlights this line as the issue:
FirstFoundAddress = DiscrepancyFound.Address

I'm really sorry to be a nuisance, but could you tell me please have you any idea where I may be going wrong?Many thanks and kind regards

SamT
07-22-2013, 06:49 AM
No problem, Helps me learn too.

With just one Epid, you've created a situation I had not considered, No Discrepancies. I amended the FirstFoundAddress to handle this.

Resize is fairly new to me and I think I was using it wrong. After looking at the Helps some more, I think Then to Resize columns Only:

Range.Resize(1,7)
'or
Range.Resize(ColumnSize:=7)
'This might also work. Experiments need to be sure.
Range.Resize(,7)


Option Explicit
Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim ECell As Range
Dim DiscrepancyFound As Range
Dim PasteRng As Range
Dim LastRow As Long
Dim FirstFoundAddress As String

LastRow = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = Workbooks("Extracted Data.xlsm").Sheets("Extract").Range("B7:B" & LastRow)

LastRow = Workbooks("SIP.xlsm").Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = Workbooks("SIP.xlsm").Sheets("Staff").Range("B7:B" & LastRow)

Set PasteRng = Workbooks("Extracted Data.xlsm").Sheets("Completed").Range("B7:H7")

For Each ECell In EpidRng
Set DiscrepancyFound = SpidRng.Find(ECell)

If DiscrepancyFound Is Nothing Then
MsgBox "No Discrepancies Found."
Else
FirstFoundAddress = DiscrepancyFound.Address
End If

' Do Until DiscrepancyFound = Nothing
Do While Not DiscrepancyFound Is Nothing
If DiscrepancyFound.Address = FirstFoundAddress Then Exit Do
Set DiscrepancyFound = DiscrepancyFound.Resize(1, 7)
DiscrepancyFound.Copy Destination:= PasteRng
Set PasteRng = PasteRng.Offset(1, 0)
Set DiscrepancyFound = SpidRng.FindNext(ECell)
Loop
Next ECell

End Sub

hobbiton73
07-22-2013, 10:48 PM
Hi @SamT, thank you very much for coming back to me witn this.I can now get the script to run withthout any error messages which is great, but unfortunately the information is not copied and paste into the destination sheet i.e. "Completed".Many thanks and kind regardsChris

SamT
07-23-2013, 05:39 AM
Upload the two workbooks for me to look at. Make sure there are at least 3 EPids and 5 Spids, with at least 2 discrepancies.

Try this first
DiscrepancyFound.Copy Destination:= PasteRng[/vba][vba]DiscrepancyFound.Copy
PasteRng.PAsteSpecial

hobbiton73
07-27-2013, 07:08 AM
Hi @SamT thank you very much for your continued help with this and my sincere apologies for not coming back to you sooner.

Please find attached the files you've asked for. However, because the system only allows one file to be uploaded I've incorporated all the sheets into one file.

Many thanks and kind regards

Chris

SamT
07-27-2013, 08:44 AM
Much easier with a sample. I had to change the names of the various workbooks to "ThisWorkbook", so you'll have to edit them back in.

]Sub ReportSIPDiscrepancies()
Dim EpidRng As Range 'Lcase "PID" for readablity
Dim SpidRng As Range
Dim SCell As Range
Dim DiscrepancyFound As Range
Dim PasteRng As Range
Dim LastRow As Long
Dim FirstFoundAddress As String
Dim Count As Variant

LastRow = ThisWorkbook.Sheets("Extract").Range("B7").End(xlDown).Row
Set EpidRng = ThisWorkbook.Sheets("Extract").Range("B7:B" & LastRow)

LastRow = ThisWorkbook.Sheets("Staff").Range("B7").End(xlDown).Row
Set SpidRng = ThisWorkbook.Sheets("Staff").Range("B7:B" & LastRow)

Set PasteRng = ThisWorkbook.Sheets("Completed").Range("B7:H7")

For Each SCell In SpidRng
With EpidRng
Set DiscrepancyFound = .Find(What:=SCell, After:=EpidRng.Range("A1").End(xlDown))
If DiscrepancyFound Is Nothing Then GoTo SCellNext

FirstFoundAddress = DiscrepancyFound.Address
Do
Count = Count + 1
Set DiscrepancyFound = DiscrepancyFound.Resize(1, 7)
DiscrepancyFound.Copy Destination:=PasteRng
Set PasteRng = PasteRng.Offset(1, 0)
Set DiscrepancyFound = .FindNext(After:=DiscrepancyFound.Range("A1"))
Loop Until DiscrepancyFound.Address = FirstFoundAddress
End With

SCellNext:
Next SCell

If Count = "" Then Count = "No"
MsgBox Count & " Discrepancies were found"

End Sub

hobbiton73
07-27-2013, 10:10 AM
Hi @SamT, thank you so much for this, it works great, and along with the guidance you provided earlier, it gives me, what I think is a god starting point to look at creating my own macros.

Once again, many thanks for all your time, trouble and effort, it's greatly appreciated.

Kind Regards

SamT
07-27-2013, 11:53 AM
:beerchug: