none
making scorecard with data pulled from flat files more dynamic in excel-VBA RRS feed

  • Question

  • 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) enter image description here

    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:

    enter image description here

    enter image description here

    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


    • Edited by durba138 Monday, July 25, 2016 6:02 PM
    Monday, July 25, 2016 6:01 PM