Updating Macro to Be More Dynamic

somedood

New Member
Joined
Mar 16, 2017
Messages
17
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 NameLast NameIDEmailPhoneClassIDMath Grade 1History Grade 1Science Grade 1Math Grade 2History Grade 2Science Grade 2Math Grade 3History Grade 3Science Grade 3Finalized?
ClarkKent
1​
13​
1​
1​
1​
Yes
DianaPrince
2​
51​
1​
1​
1​
1​
1​
1​
1​
1​
1​
Yes
BruceWayne
3​
21​
1​
1​
1​
No

After macro:
First NameLast NameIDEmailPhoneClassIDMathHistoryScienceMath Grade 1History Grade 1Science Grade 1Math Grade 2History Grade 2Science Grade 2Math Grade 3History Grade 3Science Grade 3Finalized?
ClarkKent
1​
13​
1, 23
1​
1​
1​
Yes
DianaPrince
2​
51​
1, 2, 31, 2, 31, 2, 3
1​
1​
1​
1​
1​
1​
1​
1​
1​
Yes
BruceWayne
3​
21​
12, 3
1​
1​
1​
No

Before macro (with column deleted):
First NameLast NameIDEmailPhoneClassIDMath Grade 1History Grade 1Science Grade 1Math Grade 2History Grade 2Science Grade 2Finalized?
ClarkKent
1​
13​
1​
1​
Yes
DianaPrince
2​
51​
1​
1​
1​
1​
1​
1​
Yes
BruceWayne
3​
21​
1​
1​
No

After macro (with column deleted):
First NameLast NameIDEmailPhoneClassIDMathHistoryScienceMath Grade 1History Grade 1Science Grade 1Math Grade 2History Grade 2Science Grade 2Finalized?
ClarkKent
1​
13​
1, 2, 3
1​
1​
Yes
DianaPrince
2​
51​
1, 2, 31, 21, 2
1​
1​
1​
1​
1​
1​
Yes
BruceWayne
3​
21​
312
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
VBA 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:

VBA Code:
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:
VBA Code:
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.
 

Some videos you may like

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,273
Office Version
  1. 365
Platform
  1. Windows
How about using a UDF?
VBA Code:
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.
Code:
=GetGrades( "Math", $G$1:$O$1, G2:O2)
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238
Try:
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,777
Messages
5,626,820
Members
416,202
Latest member
donya ba

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top