Making scorecard with data pulled from flat files more dynamic in excel-VBA

[durba138]

I made up this sports data so none of it is accurate or even remotely right but it is for the sake of the real data I am using. (Sorry it's a long explanation)

http://i.stack.imgur.com/3ay85.png

Overview: This is a picture of a scorecard I am working on that reports on various metrics related to sports data. It starts with a scoring of the overall category of sports and then scoring a breakdown of each sport. So we can call "Sports" the parent category and all the ones to its right the child categories.


How data is read in: For example, the Games Won sub looks through the Games Won column in the separate flat file (Games Won) of data for any "G T 50 Ga" (greater than 50 games). It then looks through the Category column to make sure it's a sports category, and then it goes to the athlete name to find who won those games. The macro writes if it is this athlete, AND they won more than 50 games, add to that athlete's sport denominator and numerator, else they didn't win 50 games add only to the denominator. However, the flat files don't contain which specific sport each athlete name goes to which is why it has to be all outlined in the macros which is tedious and seems unnecessary. Heres the flat file:

http://i.stack.imgur.com/ahcnp.png

http://i.stack.imgur.com/6rjer.png

What I'd like to be able to do: I have created a reference file pictured above here that has each sport, the athlete that plays it, and their respective hierarchies. Somehow, I want to be able to have a macro that goes through the flat file, finds the criteria it needs (ex: G T 50 G, Sports) and once it finds an athlete or hierarchy associated with the criteria, it searches through the reference file and associates it with a specific child (sport), and then adds to that sports respective numerators and denominators. If a sport or athlete name changes one month, the scorecard breaks because I would have to go in to each individual sub metric and change the information. If I could just go into a reference file and change it, that would be a lot easier. Again, not entirely sure how to go about connecting a reference file with all of this.

Here's an example of a sub for the Games Won metric:

Sub CalcMetric_Games_Won()

For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = "Games won (percentage)" Then

 Dim tennis_n, tennis_d, baseball_n, baseball_d, soccer_n, soccer_d As Long
  Dim sports_n, sports_d, FinalRow As Long
 Dim Games_Column, Name_Column, Category_Column, i As Long

 Dim CWS As Worksheet


 Set CWS = Worksheets("ActiveWS")

 tennis_n = 0
 tennis_d = 0
 baseball_n = 0
 baseball_d
 soccer_n = 0
 soccer_d = 0
 sports_n = 0
 sports_d = 0

 ThisBook = ActiveWorkbook.Name

 Workbooks.Open Filename:=ThisWorkbook.Path & "\athleticsdata.xlsb"
 Sheets("Games Won").Activate
 FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
 HeaderRow = Cells(FinalRow, 2).End(xlUp).Row

    'Find Metric Columns
   Cells(HeaderRow, 1).Activate
   Cells.Find(What:="Games Won", After:=ActiveCell, LookIn:=xlValues _
   , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False).Activate
   Games_Column = ActiveCell.Column

   Cells.Find(What:="Category", After:=ActiveCell, LookIn:=xlValues _
   , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False).Activate
   Category_Column = ActiveCell.Column

   Cells.Find(What:="Athlete Name", After:=ActiveCell, LookIn:=xlValues _
   , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False).Activate
   Name_Column = ActiveCell.Column

 For i = (HeaderRow + 1) To FinalRow

  Select Case LCase(Left(Cells(i, Name_Column).Value, 12))
  Case "Williams, Serena"
        tennis_d = tennis_d + 1
        If Left(Cells(i, Games_Column).Value, 9) = "G T 50 Ga" Then
        tennis_n = tennis_n + 1
        End If

  Case "Jeter, Derek"
        baseball_d = baseball_d + 1
        If Left(Cells(i, Games_Column).Value, 9) = "G T 50 Ga" Then
        baseball_n = baseball_n + 1
        End If

   Case "Beckham, David", "Ronaldo, Cristiano"
        soccer_d = soccer_d + 1
        If Left(Cells(i, Aging_Column).Value, 9) = "G T 50 Ga" Then
        soccer_n = soccer_n + 1
        End If

   End Select
  Next i

  For i = (HeaderRow + 1) To FinalRow
    Select Case Left(Cells(i, Name_Column).Value, 4)
   Case "Sports" 
        sports_d = sports_d + 1
        If Left(Cells(i, Games_Column).Value, 9) = "G T 50 Ga" Then
        sports_n = sports_n + 1
        End If

    End Select
   Next i


 'Write results
    Workbooks(ThisBook).Activate


  For j = 5 To 15
   With CWS
   For g = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
    With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
     On Error Resume Next
      If Cells(3, g) = "Sports" Then
            Cells(k + 1, g).Value = sports_n
            Cells(k + 1, g + 2).Value = sports_x
        ElseIf Cells(3, g) = "Tennis" Then
            Cells(k + 1, g).Value = tennis_n
            Cells(k + 1, g + 2).Value = tennis_x
        ElseIf Cells(3, g) = "Baseball" Then
            Cells(k + 1, g).Value = baseball_n
            Cells(k + 1, g + 2).Value = baseball_x
        ElseIf Cells(3, g) = "Soccer" Then
            Cells(k + 1, g).Value = soccer_n
            Cells(k + 1, g + 2).Value = soccer_x
                 End If
     End With
   Next g
   End With
 On Error GoTo 0
Next j

  End If
  Next k
 End Sub

P.S. NDTR stands for no data to report