How to add another criteria to this macro, and copy a range of cells instead the entire row.

[Lehoi]

Hello

I am using this macro to split the data from "Daily Data" worksheet into existing soccer Teams worksheets according to the Time of the new data (D column).

Right now, the macro looks for the worksheets of Teams listed in "Daily Data" E column "Home" and add the data based on column D "Time" time of the match.

What I am looking for is to find also for the worksheets of the teams listed in "Daily Data" columna G "Away" and add its data based on column D "Time" time of the match.

The other request is how to copy only the data in the range A:G, to avoid overwriting data in subsequent columns.

Thank you all in advance

edit: This is the sample workbook:
https://www.dropbox.com/s/rfa83cxkciwc68f/Prueba añadir datos nuevos.xlsb?dl=0

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 GoTo Handler
        Set TrgSheet = Worksheets(Team)
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
        If Application.CountIf(TrgSheet.Range("D:D"), SrcSheet.Cells(SrcRow, "D").Value) > 0 Then 
            MsgBox "Duplicate Detected for " & SrcSheet.Cells(SrcRow, "D").Value
        Else
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        End If
Handler:
    Next SrcRow
    'Application.ScreenUpdating = True
End Sub

 

[wideboydixon]

Some minor changes:

Sub SplitData()
   
    Const HomeCol = 5
    Const AwayCol = 7
    Const HeaderRow = 1
    Const FirstRow = 2
    
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim SrcCol As Long
    Dim lastRow As Long
    Dim TrgRow As Long
    Dim Team As String
    
    'Application.ScreenUpdating = False
    On Error Resume Next
    
    Set SrcSheet = ActiveWorkbook.Worksheets("Daily Data")
    lastRow = SrcSheet.Cells(SrcSheet.Rows.Count, HomeCol).End(xlUp).Row
    For SrcRow = FirstRow To lastRow
        For SrcCol = HomeCol To AwayCol Step AwayCol - HomeCol
            Team = SrcSheet.Cells(SrcRow, SrcCol).Value
            Set TrgSheet = Nothing
            Set TrgSheet = Worksheets(Team)
            If Not TrgSheet Is Nothing Then
                TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, HomeCol).End(xlUp).Row + 1
                If Application.CountIf(TrgSheet.Range("D:D"), SrcSheet.Cells(SrcRow, "D").Value) > 0 Then
                    MsgBox "Duplicate Detected for " & SrcSheet.Cells(SrcRow, "D").Value
                Else
                    SrcSheet.Range(SrcSheet.Cells(SrcRow, 1), SrcSheet.Cells(SrcRow, 7)).Copy Destination:=TrgSheet.Cells(TrgRow, 1)
                End If
            End If
        Next SrcCol
    Next SrcRow
    
    'Application.ScreenUpdating = True
    
End Sub

Please note that I didn't test this as I didn't have your data to hand ...

WBD

 

[Lehoi]

Wow wideboydixon that was FAST!

Works perfect! , thank you very much!!!

Lehoi

 

[wideboydixon]

"Blind" coding is always a challenge Glad I got it right. Enjoy

WBD

 

[Lehoi]

"Blind" coding is always a challenge Glad I got it right. Enjoy

WBD

You are like japanese master Zatoichi, blind but Fast!

 

[Lehoi]

Hi
Sorry for this last request.
I know for changing the range per example from A:G to A:F I must change the 7 value to 6 in this line:

SrcSheet.Range(SrcSheet.Cells(SrcRow, 1), SrcSheet.Cells(SrcRow, 7)).Copy Destination:=TrgSheet.Cells(TrgRow, 1)


But, if I want to copying the data starting from C column how can I do that? I tried some things like Offset, etc. but no luck

 

[Lehoi]

Hi
User cerfani gave me a solution to the last request I made in this thread, is this (maybe somebody besides me, can use it for his projects):

[COLOR=#333333]Sub SplitData()[/COLOR]

    Const HomeCol = 5
    Const AwayCol = 7
    Const HeaderRow = 1
    Const FirstRow = 2

    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim SrcCol As Long
    Dim lastRow As Long
    Dim TrgRow As Long
    Dim Team As String

    Application.ScreenUpdating = False
    On Error Resume Next

    Set SrcSheet = ActiveWorkbook.Worksheets("Daily Data")
    lastRow = SrcSheet.Cells(SrcSheet.Rows.Count, HomeCol).End(xlUp).Row
    For SrcRow = FirstRow To lastRow
        For SrcCol = HomeCol To AwayCol Step AwayCol - HomeCol
            Team = SrcSheet.Cells(SrcRow, SrcCol).Value
            Set TrgSheet = Nothing
            Set TrgSheet = Worksheets(Team)
            If Not TrgSheet Is Nothing Then
                TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, HomeCol).End(xlUp).Row + 1
                If Application.CountIf(TrgSheet.Range("D:D"), SrcSheet.Cells(SrcRow, 4).Value) > 0 Then
                    MsgBox "Duplicate Detected for " & SrcSheet.Cells(SrcRow, 4).Value
                Else
                    SrcSheet.Range(SrcSheet.Cells(SrcRow, 3), SrcSheet.Cells(SrcRow, 7)).Copy Destination:=TrgSheet.Range(TrgSheet.Cells(TrgRow, 3), TrgSheet.Cells(TrgRow, 7))
                End If
            End If
        Next SrcCol
    Next SrcRow
    Application.ScreenUpdating = True

 [COLOR=#333333]End Sub
[/COLOR]

Regards