Any idea how to modify this macro to copy only unique data into all worksheets?

[Lehoi]

Hi

I am using this macro to extract data from Master Sheet "Daily Data" to other worksheets:

Sub SplitData()

    Const NameCol = "E"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim lastRow As Long
    Dim TrgRow As Long
    Dim Team As String
    Application.ScreenUpdating = False

    Set SrcSheet = ActiveWorkbook.Worksheets("Daily Data")
    lastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
    For SrcRow = FirstRow To lastRow
        Team = SrcSheet.Cells(SrcRow, NameCol).Value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(Team)
        On Error GoTo 0
        If TrgSheet Is Nothing Then
            Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            TrgSheet.name = Team
            SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
        End If
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
        SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
    Next SrcRow
    Application.ScreenUpdating = True
End Sub

What I am looking for is to add only new data into worksheets to prevent duplicate data.

Besides that, how can I prevent the creation of new worksheets if doesn't exist?
I only need add new data to existing worksheets, if column E has values without coincident worksheets, ignore them.

Any help would be appreciated
Regards
Lehoi

 

[JLGWhiz]

try this

Sub SplitData()
    Const NameCol = "E"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim lastRow As Long
    Dim TrgRow As Long
    Dim Team As String
    Application.ScreenUpdating = False
    Set SrcSheet = ActiveWorkbook.Worksheets("Daily Data")
    lastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
    For SrcRow = FirstRow To lastRow
        Team = SrcSheet.Cells(SrcRow, NameCol).Value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(Team)
        If Err.Number = 9 Then Exit Sub
        On Error GoTo 0
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
        If Application.CountIf(TrgSheet.Range("E:E"), SrcSheet.Cells(SrcRow, "E").Value) > 0 Then
            MsgBox "Duplicate Detected for " & SrcSheet.Cells(SrcRow, "E").Value
        Else
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        End If
    Next SrcRow
    Application.ScreenUpdating = True
End Sub

 

[Lehoi]

Hi JLGWhiz

Thank you very much for the quick response.

I tested the macro and maybe because of my basic english I am not explained very well, sorry.
In line
If Application.CountIf(TrgSheet.Range("E:E"), SrcSheet.Cells(SrcRow, "E").Value) > 0 Then
I changed the > sign to < to achieve my goal, and now the data in existing worksheet is updated with new data correctly.
Please can you tell me if I made the right solution.


Now I have a strange problem ... Per example: In the worksheet "Daily Data" in cell E2, the value does not match with the name of any worksheet, so this row must not be copied, but in cell E3 there is a matching value with the name of a spreadsheet and the values of this row (the row correspondent to E3) is not copied to the destination worksheet. Any idea what could cause this behavior?

regards

 

[Lehoi]

Compettion	Compettion	Status	Time	Home	Score	Away
AUS VL2	Australia NPL Victoria 1 Regular Season	FT	25-06-16 7:00	Melbourne City Youth	1-2 (1-1)	St Albans Saints
AUS VL2	Australia NPL Victoria 1 Regular Season	FT	25-06-16 7:00	Eastern Lions	2-0 (1-0)	Springvale W.Eagles

<tbody>
</tbody>

This is how the Daily Data worksheet looks. In the workbook the Eastern Lions worksheet exist, but the row with the Eastern Lions data isn't copied to its worksheet because the Melbourne City Youth doesn't have its worksheet.

I commented the line On Error Resume Next to see the error and is this:
the macro stops on line:
Set TrgSheet = Worksheets(Team)

and shows this msg:
Run-time error '9':
Subscript out of range

 

[JLGWhiz]

Hi JLGWhiz

Thank you very much for the quick response.

If Application.CountIf(TrgSheet.Range("E:E"), SrcSheet.Cells(SrcRow, "E").Value) > 0 Then
[/C]OLORI changed the > sign to < to achieve my goal, and now the data in existing worksheet is updated with new data correctly.
Please can you tell me if I made the right solution.

regards

The line is only part of a complete statement

If Application.CountIf(TrgSheet.Range("E:E"), SrcSheet.Cells(SrcRow, "E").Value) > 0 Then
            MsgBox "Duplicate Detected for " & SrcSheet.Cells(SrcRow, "E").Value
        Else
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        End If

The > symbol tests wheter there is an existing record of the same value already in the destination sheet. If there is, it will simply go to the next item in the loop. If the CountIf = 0 then it will copy the new (unique) row from the source sheet to the destination sheet. If you change the symbol to < then the CountIf will never be true and it will copy every item in the source sheet to the destination sheet.

Now I have a strange problem ... Per example: In the worksheet "Daily Data" in cell E2, the value does not match with the name of any worksheet, so this row must not be copied, but in cell E3 there is a matching value with the name of a spreadsheet and the values of this row (the row correspondent to E3) is not copied to the destination worksheet. Any idea what could cause this behavior?

Check your spelling and whether upper or lower case, etc. Sounds like a typo or misplaced character problem. Could even be leading or trailing spaces.

 

[JLGWhiz]

Compettion	Compettion	Status	Time	Home	Score	Away
AUS VL2	Australia NPL Victoria 1 Regular Season	FT	25-06-16 7:00	Melbourne City Youth	1-2 (1-1)	St Albans Saints
AUS VL2	Australia NPL Victoria 1 Regular Season	FT	25-06-16 7:00	Eastern Lions	2-0 (1-0)	Springvale W.Eagles

<tbody>
</tbody>

This is how the Daily Data worksheet looks. In the workbook the Eastern Lions worksheet exist, but the row with the Eastern Lions data isn't copied to its worksheet because the Melbourne City Youth doesn't have its worksheet.

I commented the line On Error Resume Next to see the error and is this:
the macro stops on line:
Set TrgSheet = Worksheets(Team)

and shows this msg:
Run-time error '9':
Subscript out of range

OK, that is my fault. I deleted the original On Error Resume Next statement that created a new worksheet because you said you didn't want a new sheet. In its place, I put an Exit Sub which would stop the process if no team sheet exists. Do you want that back in there?

 

[Lehoi]

I change the sign to the original way as you suggest and works ok now, maybe I did something wrong the first time.

I checked the spelling of the name of the worksheet and the cell E3 and is identical check spaces too, is odd.

edir: I just saw your recent post. I don't want to add new sheets, but in this case the Eastern Lions sheet exist but the Eastern Lions data were not copied to its worksheet. If I delete the Melbourne City Youth row the Eastern Lions data were copied correctly.

 

[JLGWhiz]

The Subscript out of Range message means that VBA could not find the object it was looking for. I suggest that you re-type the name into E3 to eliminate the posibility of any unseen spaces or symbols and try it. If it stll gives the error 9 message, try re-typing the name on the sheet tab. If still error, then you will need to try and find why the two do not match. I can't help you much from this end on that one.

 

[Lehoi]

No problem JLGWhiz, already you helped me alot. As you said, maybe is something about names but I can find the error yet.

Thank you very much for your time, and above all, for your patience with me.

Regards
Lehoi

 

[JLGWhiz]

No problem JLGWhiz, already you helped me alot. As you said, maybe is something about names but I can find the error yet.

Thank you very much for your time, and above all, for your patience with me.

Regards
Lehoi

Good luck,
Regards, JLG