Best way to make all-time leading scorers sheet from multiple sheets

[confuxion]

So I've gone through the arduous process of collecting (in Excel) 20 season's worth of individual scoring stats for the HS hockey team my son plays for. Every season is contained in it's own sheet, with individual stats for each player. I'm looking for the best approach to creating an additional sheet that compiles an all-time leading scorers list among those 20 seasons; one that will keep the manual data-entry to a minimum. Given that high school is 4 years, many players appear on upwards of 4 different sheets. This is more about the approach in trying to collect every player and their associated career stats onto one sheet. My initial thought is to use VLOOKUPS on player names across all 20 sheets, but the best way to do this escapes me. Maybe this is simpler than I think. Thanks in advance for any tips/ideas!

 

[Peter_SSs]

Column B needs to get accumulated onto the results sheet as well.

Yes I missed that one in my list.

Give this one a try. I have sorted the results by PTS but not made a formal table. I don't think that is required as you can still sort using the AutoFilter drop-downs that I have created.

You might also double-check the formulas & their results. It looks to me like your original formula in column L in post #17 is not correct. You have parentheses around I4+J4 in one part but not the error checking part. I have replaced your IF(ISERROR with the single function IFERROR(

Sub Career_Stats_v2()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim ws As Worksheet
  Dim i As Long, j As Long, k As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  ReDim b(1 To Rows.Count, 1 To 10)
  For Each ws In Worksheets
    If ws.Name Like "####" Then
      a = ws.Range("A4", ws.Range("A" & Rows.Count).End(xlUp).Offset(-2)).Resize(, 10).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          d(a(i, 1)) = d.Count + 1
          b(d.Count, 1) = a(i, 1)
        End If
        k = d(a(i, 1))
        For j = 2 To 10
          b(k, j) = b(k, j) + a(i, j)
        Next j
      Next i
    End If
  Next ws
  Application.ScreenUpdating = False
  With Sheets("CAREER")
    .AutoFilterMode = False
    .UsedRange.Offset(3).EntireRow.Delete
    With .Range("A4").Resize(d.Count, 10)
      .Value = b
      .Columns(5).Formula = "=C4+D4"
      .Columns(11).Formula = "=IFERROR(C4/H4,0)"
      .Columns(12).Formula = "=IFERROR(I4/(I4+J4),0)"
      .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo
      .Offset(-1).Resize(d.Count + 1, 12).AutoFilter
    End With
    With .Range("A" & Rows.Count).End(xlUp).Offset(2)
      .Value = "TOTALS"
      .Offset(, 2).Resize(, 8).FormulaR1C1 = "=SUM(R4C:R[-1]C)"
      .Offset(, 10).FormulaR1C1 = "=IFERROR(RC[-8]/RC[-3],0)"
      .Offset(, 11).FormulaR1C1 = "=IFERROR(RC[-3]/(RC[-3]+RC[-2]),0)"
      .EntireRow.Font.Bold = True
    End With
    .UsedRange.Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[confuxion]

Wow, this is great! So given that the nature of this solution is (for lack of a better word) "static," in that I have to run it each time any data is added to one of the sheets it pulls from, what would be the additional code that would be needed to convert Sh% and FO% to actual percentages within the routine (they compute as extended decimal values)? I can look up how to do the simple stuff, like converting all the gathered career data into a certain font-face and size. Also, will the macro choke on any columns that don't have data? As I said before, the data varies between the 20+ sheets that I have, even thought they all have Ga, G, A, and PTS. Thank you so much for this! I did not expect this level of expertise and willingness to help. Much appreciated!

 

[Peter_SSs]

what would be the additional code that would be needed to convert Sh% and FO% to actual percentages

Do you mean have them as numbers rather than formulas? If so, you can't do that on the fly, they need to be calculated at the end but the modified code below removes the formulas and keeps the formula results.
You may want to consider rounding the results though so there are not so many decimal places?

Sub Career_Stats_v3()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim ws As Worksheet
  Dim i As Long, j As Long, k As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  ReDim b(1 To Rows.Count, 1 To 10)
  For Each ws In Worksheets
    If ws.Name Like "####" Then
      a = ws.Range("A4", ws.Range("A" & Rows.Count).End(xlUp).Offset(-2)).Resize(, 10).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          d(a(i, 1)) = d.Count + 1
          b(d.Count, 1) = a(i, 1)
        End If
        k = d(a(i, 1))
        For j = 2 To 10
          b(k, j) = b(k, j) + a(i, j)
        Next j
      Next i
    End If
  Next ws
  Application.ScreenUpdating = False
  With Sheets("CAREER")
    .AutoFilterMode = False
    .UsedRange.Offset(3).EntireRow.Delete
    With .Range("A4").Resize(d.Count, 10)
      .Value = b
      .Columns(5).Formula = "=C4+D4"
      .Columns(11).Formula = "=IFERROR(C4/H4,0)"
      .Columns(12).Formula = "=IFERROR(I4/(I4+J4),0)"
      .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo
      .Offset(-1).Resize(d.Count + 1, 12).AutoFilter
    End With
    With .Range("A" & Rows.Count).End(xlUp).Offset(2)
      .Value = "TOTALS"
      .Offset(, 2).Resize(, 8).FormulaR1C1 = "=SUM(R4C:R[-1]C)"
      .Offset(, 10).FormulaR1C1 = "=IFERROR(RC[-8]/RC[-3],0)"
      .Offset(, 11).FormulaR1C1 = "=IFERROR(RC[-3]/(RC[-3]+RC[-2]),0)"
      .EntireRow.Font.Bold = True
    End With
    With .UsedRange
      .Columns.AutoFit
      .Value = .Value
    End With
  End With
  Application.ScreenUpdating = True
End Sub

I have to run it each time any data is added to one of the sheets it pulls from

That does not need to be the case. If you add the following code to the 'CAREER' worksheet module then the results will automatically recalculate each time you go to the 'CAREER' worksheet.
To add the code to the correct place right click the "CAREER' sheet name tab and choose 'View Code' Paste the short code below into the main right hand vba window.

Private Sub Worksheet_Activate()
  Career_Stats_v3
End Sub

will the macro choke on any columns that don't have data?

If I understand that correctly then 'no' that should not be a problem as it would simply add zero for each of the empty cells.

 

[confuxion]

That addition of the VBA code for the CAREER sheet to update it every time it's viewed is great! However, whenever that sheet is clicked on, the Sh% and FO% values are converted back to long decimals after manually switching them to percentages and rounding them correctly just prior. For example, "8.75%" will go back to "0.0875." Is there a way to adjust the VBA code so that those values will retain their formatting as percentages instead of long decimals?

 

[Peter_SSs]

Manually format the entire columns K:L in 'CAREER' to be Percentage with 1 decimal place (or whatever other formatting you want). The columns will retain that formatting when the code runs again.

Note that although that will display the percentage to one decimal place, the underlying value in the cell will retain the many decimal places. Click on one of the cells and look in the formula bar to see the actual number.

If you want the final value in the cell to be the rounded number then try this code. The changed lines are highlighted blue.

Sub Career_Stats_v3()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim ws As Worksheet
  Dim i As Long, j As Long, k As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  ReDim b(1 To Rows.Count, 1 To 10)
  For Each ws In Worksheets
    If ws.Name Like "####" Then
      a = ws.Range("A4", ws.Range("A" & Rows.Count).End(xlUp).Offset(-2)).Resize(, 10).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          d(a(i, 1)) = d.Count + 1
          b(d.Count, 1) = a(i, 1)
        End If
        k = d(a(i, 1))
        For j = 2 To 10
          b(k, j) = b(k, j) + a(i, j)
        Next j
      Next i
    End If
  Next ws
  Application.ScreenUpdating = False
  With Sheets("CAREER")
    .AutoFilterMode = False
    .UsedRange.Offset(3).EntireRow.Delete
    With .Range("A4").Resize(d.Count, 10)
      .Value = b
      .Columns(5).Formula = "=C4+D4"
      .Columns(11).Formula = "=IFERROR(ROUND(C4/H4,3),0)"
      .Columns(12).Formula = "=IFERROR(ROUND(I4/(I4+J4),3),0)"
      .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo
      .Offset(-1).Resize(d.Count + 1, 12).AutoFilter
    End With
    With .Range("A" & Rows.Count).End(xlUp).Offset(2)
      .Value = "TOTALS"
      .Offset(, 2).Resize(, 8).FormulaR1C1 = "=SUM(R4C:R[-1]C)"
      .Offset(, 10).FormulaR1C1 = "=IFERROR(ROUND(RC[-8]/RC[-3],3),0)"
      .Offset(, 11).FormulaR1C1 = "=IFERROR(ROUND(RC[-3]/(RC[-3]+RC[-2]),3),0)"
      .EntireRow.Font.Bold = True
    End With
    With .UsedRange
      .Columns.AutoFit
      .Value = .Value
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[confuxion]

Hello again! I took the most recent code you created and put it in a macro in the working file I'm using for the stats. However, when I run the macro "Career_Stats_v3" I get a runtime error (I'll include screenshots). When I click on "Debug" it points out the following code (again, see screenshot): There are 15 sheets, each representing stats from one season, in the workbook. The final sheets "CAREER" appears at the end, and has the same headers in the first 3 rows as the other sheets. Any ideas?