I have nfl grid schedule. I press button to put team schedule on own worksheet is error in vba code

sf49ers19238597 

Sub J3v16()
    Dim Data, Team, Chk, Hdr, i As Long, r As Long
    Dim w As Worksheet
    Application.ScreenUpdating = False
    Data = Sheets("Teams").Cells(1).CurrentRegion
    Hdr = Array("WEEKS", "OPPONENTS", "AWAY OR HOME")
    With Sheets("Transposes").Cells(1).CurrentRegion
        .Replace "@", "'@"
        For i = 1 To UBound(Data)
            .Replace Data(i, 1), Data(i, 2), xlWhole
            .Replace "*" & Data(i, 1), "@" & Data(i, 2), xlWhole
        Next i
        For i = 1 To UBound(Data)
            Chk = Application.Match(Data(i, 2), .Rows(1), 0)
            Team = .Cells(1, Chk).Offset(1).Resize(18).Value
            On Error Resume Next
            Set w = Worksheets(Data(i, 2))
            On Error GoTo 0
            If w Is Nothing Then
                Set w = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                w.Name = Data(i, 2)
                w.Cells(1, 1).Resize(, 3) = Hdr
                w.Cells(2, 1).Resize(18) = Evaluate("Row(1:18)")
            End If
            With w
                .Cells(2, 2).Resize(18) = Team
                For r = 2 To 19
                    If InStr(.Cells(r, 2).Value, "@") Then
                        .Cells(r, 3).Value = "AWAY"
                        .Cells(r, 2).Value = Replace(.Cells(r, 2).Value, "@", "")
                    Else
                        .Cells(r, 3).Value = "HOME"
                    End If
                Next r
                .Columns.AutoFit
            End With
        Next i
        .Columns.AutoFit: .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub