Copilot for Microsoft 365 Tech Accelerator
Feb 28 2024 07:00 AM - Feb 29 2024 10:30 AM (PST)
Microsoft Tech Community

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

Iron Contributor

I have nfl grid schedule. I press football icon  button to put team schedule on own worksheet stop at colts worksheet.  is error in vba code

11 Replies

@sf49ers19238597 

After deleting the existing sheets named after teams, your macro ran without errors.

@sf49ers19238597 

The sheets named 49ERS, BEARS, BENGALS etc. - in other words, the ones whose name is listed in column B of the TEAMS sheet. The code creates a new sheet for each of these names, but if a sheet of that name already exists, you'll get an error.

@Hans Vogelaar 

 

I just got it work now.

 

How change code.

How I put @ in column C than put AWAY instead of @.

 

If no @ in column C. put HOME.

 

Than remove @ in column B.

for all 32 teams own worksheets.

 

Bills Sample is should column C look like. I still have @ in column B

 

 

 

@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
I try copy your code all is in red on my end

@sf49ers19238597 

Workbook with my version of the macro attached...

@Hans Vogelaar 

 

I saw you done one team only. How get rest of 31 teams schedule?

@Hans Vogelaar 

 

 

 I put new code in. I run the macro by press football icon only give me bills only.

 

I  attach file you can see. 

@sf49ers19238597 

My apologies, I omitted one line from the code.