Updating Macro to Be More Dynamic

[somedood]

Hi everyone. Hope you all are doing well. I've been struggling with a macro update for a while now. I'm trying to count cell values ONLY when the column name is like Math, Science, or History. The issue is that the code is somewhat static. If a Math, History, or Science column is deleted, it throws off the counts and ends up counting the next column that should be in the spot of one of the grades. I want columns to only be counted when the column name is Math, Sci, or History. I want the code to be somewhat dynamic, in case my customer needs to add/delete columns.

Before macro:

First Name

Last Name

ID

Email

Phone

ClassID

Math Grade 1

History Grade 1

Science Grade 1

Math Grade 2

History Grade 2

Science Grade 2

Math Grade 3

History Grade 3

Science Grade 3

Finalized?

Clark

Kent

1​

13​

1​

1​

1​

Yes

Diana

Prince

2​

51​

1​

1​

1​

1​

1​

1​

1​

1​

1​

Yes

Bruce

Wayne

3​

21​

1​

1​

1​

No

After macro:

First Name

Last Name

ID

Email

Phone

ClassID

Math

History

Science

Math Grade 1

History Grade 1

Science Grade 1

Math Grade 2

History Grade 2

Science Grade 2

Math Grade 3

History Grade 3

Science Grade 3

Finalized?

Clark

Kent

1​

13​

1, 2

3

1​

1​

1​

Yes

Diana

Prince

2​

51​

1, 2, 3

1, 2, 3

1, 2, 3

1​

1​

1​

1​

1​

1​

1​

1​

1​

Yes

Bruce

Wayne

3​

21​

1

2, 3

1​

1​

1​

No

Before macro (with column deleted):

First Name

Last Name

ID

Email

Phone

ClassID

Math Grade 1

History Grade 1

Science Grade 1

Math Grade 2

History Grade 2

Science Grade 2

Finalized?

Clark

Kent

1​

13​

1​

1​

Yes

Diana

Prince

2​

51​

1​

1​

1​

1​

1​

1​

Yes

Bruce

Wayne

3​

21​

1​

1​

No

After macro (with column deleted):

First Name

Last Name

ID

Email

Phone

ClassID

Math

History

Science

Math Grade 1

History Grade 1

Science Grade 1

Math Grade 2

History Grade 2

Science Grade 2

Finalized?

Clark

Kent

1​

13​

1, 2, 3

1​

1​

Yes

Diana

Prince

2​

51​

1, 2, 3

1, 2

1, 2

1​

1​

1​

1​

1​

1​

Yes

Bruce

Wayne

3​

21​

3

1

2

1​

1​

No

As you can see, Finalized is getting counted, since it's in the spot that Math Grade 3 WOULD be.

Here is my code:
Original code

Sub CreateAllDataMap()
    Dim TempString As String
    TempString = ""
   
    Application.ScreenUpdating = False ' Ensure we aren't spamming the graphics engine
   
    Dim TheLastRow As Long
    TheLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row

    ' Insert the columns for the Math, History and Science maps
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight ', CopyOrigin:=xlFormatFromLeftOrAbove
   
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
    Columns("G:G").Select
"IF(RC[4]>0,""1,"","""")&IF(RC[7]>0,""2,"","""")&IF(RC[10]>0,""3,"","""")&IF(RC[13]>0,""4,"","""")&IF(RC[16]>0,""5,"","""")&IF(RC[19]>0,""6,"","""")&IF(RC[22]>0,""7,"","""")&IF(RC[25]>0,""8,"","""")&IF(RC[28]>0,""9,"","""")&IF(RC[31]>0,""10,"","""")&IF(RC[34]>0,""11,"","""")&IF(RC[37]>0,""12,"","""")&IF(RC[40]>0,""13,"","""")"
    Columns("G:G").EntireColumn.AutoFit
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Math Map"
   
    Columns("H:H").Select
    TempString = "IF(RC[4]>0,""1,"","""")&IF(RC[7]>0,""2,"","""")&IF(RC[10]>0,""3,"","""")&IF(RC[13]>0,""4,"","""")&IF(RC[16]>0,""5,"","""")&IF(RC[19]>0,""6,"","""")&IF(RC[22]>0,""7,"","""")&IF(RC[25]>0,""8,"","""")&IF(RC[28]>0,""9,"","""")&IF(RC[31]>0,""10,"","""")&IF(RC[34]>0,""11,"","""")&IF(RC[37]>0,""12,"","""")&IF(RC[40]>0,""13,"","""")"
    Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"
    Columns("H:H").EntireColumn.AutoFit
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "History Map"
   
    Columns("I:I").Select
"IF(RC[4]>0,""1,"","""")&IF(RC[7]>0,""2,"","""")&IF(RC[10]>0,""3,"","""")&IF(RC[13]>0,""4,"","""")&IF(RC[16]>0,""5,"","""")&IF(RC[19]>0,""6,"","""")&IF(RC[22]>0,""7,"","""")&IF(RC[25]>0,""8,"","""")&IF(RC[28]>0,""9,"","""")&IF(RC[31]>0,""10,"","""")&IF(RC[34]>0,""11,"","""")&IF(RC[37]>0,""12,"","""")&IF(RC[40]>0,""13,"","""")"
    Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"
    Columns("I:I").EntireColumn.AutoFit
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Science Map"
   
    ' Draw borders around the maps, and shade/color the cells
    Call HighlightAllDataMaps(TheLastRow)
   
    ' Draw the legend at the top
    Call DrawInstructions("AllData")
   
    ActiveSheet.name = "All Data Grade Map"
   
    ' If we aren't already filtering, then turn it on
    If ActiveSheet.AutoFilterMode = False Then
        [a3].Select
        Selection.AutoFilter
    End If
   
    Rows("1:1").Select
    Selection.Activate
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
   
    Rows("1:1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
  
End Sub

In place of the original temp string, I tried using:

TempString = "IF(COUNTIFS(R1C[4],""*Math*"", RC[4], "">0""),""1,"","""")&IF(COUNTIFS(R1C[7],""*Math*"", RC[7], "">0""),""2,"","""")&IF(COUNTIFS(R1C[10],""*Math*"", RC[10], "">0""),""3,"","""")&IF(COUNTIFS(R1C[13],""*Math*"", RC[13], "">0""),""4,"","""")&IF(COUNTIFS(R1C[16],""*Math*"", RC[16], "">0""),""5,"","""")&IF(COUNTIFS(R1C[19],""*Math*"", RC[19], "">0""),""6,"","""")&IF(COUNTIFS(R1C[22],""*Math*"", RC[22], "">0""),""7,"","""")&IF(COUNTIFS(R1C[25],""*Math*"", RC[25], "">0""),""4,"","""")"

It worked, but it was VERY slow (from about a minute with the original code to 6 minutes). I understand why it was slow, since it was scanning each row to make sure the column name was Math, History, or Sci.

Another thought I had was to use a formula that would ONLY count numerical values:

TempString = "IF(ISNUMBER(RC[4]),""1,"","""")&IF(ISNUMBER(RC[7]),""2,"","""")&IF(ISNUMBER(RC[10]),""3,"","""")&IF(ISNUMBER(RC[13]),""4,"","""")&IF(ISNUMBER(RC[16]),""5,"","""")&IF(ISNUMBER(RC[19]),""6,"","""")&IF(ISNUMBER(RC[22]),""7,"","""")&IF(ISNUMBER(RC[25]),""8,"","""")&IF(ISNUMBER(RC[28]),""9,"","""")&IF(ISNUMBER(RC[31]),""10,"","""")&IF(ISNUMBER(RC[34]),""11,"","""")&IF(ISNUMBER(RC[37]),""12,"","""")&IF(ISNUMBER(RC[40]),""13,"","""")"
    Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"

The issue with this one is the fact that "0" still gets counted. I'm not sure how to make ISNUMBER and "greater than 0" work together. Any help would be greatly appreciated.

 

[Norie]

How about using a UDF?

Function GetGrades(strSubject As String, rngHeader As Range, rngGrades As Range) As String
Dim rng As Range
Dim arrGrades()
Dim cnt As Long

    ReDim arrGrades(1 To rngHeader.Columns.Count)
    For Each rng In rngHeader.Cells
        If rng.Value Like "*" & strSubject & "*" And Intersect(rng.EntireColumn, rngGrades.EntireRow).Value <> "" Then
            cnt = cnt + 1
            arrGrades(cnt) = rng.Value
        End If
    Next rng
    
    If cnt > 0 Then
        ReDim Preserve arrGrades(1 To cnt)
        GetGrades = Join(arrGrades, ",")
    End If
    
End Function

You would pass in the range that has the class header, e.g. G1:O2, the subject of interest and the corresponding range for the pupil, e.g. G2:O2.

So for Clark Kent the formula would look like this.

=GetGrades( "Math", $G$1:$O$1, G2:O2)

 

[mumps]

Try:

Sub CountValues()
    Application.ScreenUpdating = False
    Dim LastRow As Long, lCol As Long, v As Variant, i As Long, fnd As Range, sAddr As String, ID As Range, x As Long: x = 7
    v = Array("Math", "History", "Science")
    Columns("G:I").Insert Shift:=xlToRight
    Range("G1").Resize(, 3) = v
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    For Each ID In Range("C2", Range("C" & Rows.Count).End(xlUp))
        For i = LBound(v) To UBound(v)
            Set fnd = Range("I1").Resize(, lCol - 9).Find(v(i), LookIn:=xlValues, lookat:=xlPart)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    If Cells(ID.Row, fnd.Column) <> "" Then
                        Cells(ID.Row, x) = Cells(ID.Row, x) & ", " & Right(Cells(1, fnd.Column), 1)
                    End If
                    Set fnd = Range("J1").Resize(, lCol - 9).FindNext(fnd)
                Loop While fnd.Address <> sAddr
                sAddr = ""
            End If
            Cells(ID.Row, x) = Mid(Cells(ID.Row, x), 3, 9999)
            x = x + 1
        Next i
        x = 7
    Next ID
    Application.ScreenUpdating = True
End Sub