Copy duplicate AND original into invidual sheets named after ANOTHER column

[bugmonsta]

This is a post I have on another forum but no-one has said if they can work this out or its one of those 'just work around it' issues. I noticed on this forum (very kindly linked from the other in some of the posts) that the majority of posts do get a response from someone so I thought I would drop this request here to see if anyone can understand/solve it or just point me in the direction I should be looking....

I have an excel document which has 3 macros in it, assigned to buttons on the first sheet (the macros are shown below but I will also attach a link to the file should anyone want to view it in action) - link to google file share

Button 1 calls a macro called KEY fills in column K where there is data in the rows and creates a key by combining column E, F and G via a simple =E3&F3&G3

Button 2 calls a macro to count column K where there is data in it and checks if its a duplicate. What this does is checks the first row K - this will always be an original, then it moves to the next row - checks the whole of column K - if its unique then its original, otherwise it reports it as a duplicate and displays what row is is a duplicate with. Moves to next row and repeats the check until there is no data in the rows.

Button 3 parses data into unique sheets - This basically splits the data into individual sheets on column A names.
In my attached example it will copy mutliple rows to a sheet called section1, then data to section2, then other rows to section3 etc.

What I cannot work out is the logic to copy duplicated data to these new sheets as well as the ones I am parsing on.

For example row 10 and 11 in my spreadhseet (shown below) are the same data but have been put under different sections so will be copied to invidual sheets called Section4 and Section5. As these are duplicates I would like them to be copied into BOTH Section4 and Section5 sheets so that I can send these out to different departments to see which one they want to keep and which one we can delete: example rows taken from the spreadsheet:

ROW	Section	JOIN DATE	ID	FAM ID	FIRST	LAST	DOB	STREET no	ADDRESS	My Key joining first, last and DOB	tells me if its original or duplciated
10	Section5	04/02/2012	D6767	D4300	Kiwi	Zuccini	07/01/2013	3	Iceland Road	KiwiZuccini41281	Original
11	Section4	06/07/2012	F5454	F0900	Kiwi	Zuccini	07/01/2013	3	Iceland Road	KiwiZuccini41281	I am a duplicate with row 10 on the master sheet

<TBODY>
</TBODY>

There is data in this spreadsheet which cannot be sent to all departments hence why I am trying to split it out to sheets to send out.

Hope this makes sense, if not then please post back and tell me This is all in Excel 2010.

Macro one is just a simple join:

' Used Marcelo Branco idea to copy the formula down the columns
Sub key()
With Sheets("Master")
.Range("K2:K" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = "=RC[-6]&RC[-5]&RC[-4]"
End With
End Sub

Macro 2 finds the duplicates:

Sub macro5()
' Used Marcelo Branco idea to copy the formula down the columns
' macro5 Macro
'
With Sheets("Master")

.Range("L2:L" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = "=IF(COUNTIF($K$2:K2,K2)>1,""I am a duplicate with row ""&MATCH(K2,K:K,0)&"" on the master sheet"",""Original"")"

End With
End Sub

Macro 3 is the biggy (by Jerry Beaucaire) that parses on the information into new sheets according to the names of column A:

Sub ParseItems()
'Author:    Jerry Beaucaire
'Date:      11/11/2009
'Summary:   Based on selected column, data is filtered to individual sheets
'           Creates sheets and sorts sheets alphabetically in workbook
'           6/10/2010 - added check to abort if only one value in vCol
'           7/22/2010 - added ability to parse numeric values consistently
'           11/16/2011 - changed way Unique values are collected, no Adv Filter
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it
   Set ws = Sheets("Master")
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
    TitleRow = Range(vTitles).Cells(1).Row
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
    
    For Itm = TitleRow + 1 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
'Sort the temporary list
    ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
    ws.Columns(iCol).Clear
'Turn on the autofilter
    ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
    
        If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
        Else                                                      'clear sheet if it exists
            Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)
            Sheets(CStr(MyArr(Itm))).Cells.Clear
        End If
    
        ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy _
            Sheets(CStr(MyArr(Itm))).Range("A1")
        
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count) _
                             .End(xlUp).Row - Range(vTitles).Rows.Count
        Sheets(CStr(MyArr(Itm))).Columns.AutoFit
    Next Itm
    
'Cleanup - added the -1 into the message twice to ensure correct count as we have inserted that extra line
    ws.AutoFilterMode = False
        ws.Activate
    MsgBox "Sharon, your rows with data: " & (LR - TitleRow - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount - 1 & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub