VBA: sumifs data and calculate score base on multiple criteria in cell value

[tendosai]

it is a bit complicated. excuse me!

I have raw_report which contain teacher name and daily attendance for student on each subject. In template, i wanna make a button so that my colleague can click and generate the score of their student base on daily attendance.

1. First, it need to look "Team Name" (one team have multiple teacher)
2. Then, it will base on date of attendance
3. Once data matches based on above criteria, it will copy/paste name of student name into the column (without duplicated) as well as their teacher name.
   In sample excel, Mr. A has 3 members so in table it will also include teacher Mr. E and Mr. F 's student accordingly.
4. with all student name in, it will SUM the subject score and total score according to subject (in sample it can be easily with sumifs but not sure in VBA)

here is the sample file Sample Test

 

[mumps]

It is not good practice to use "on error go to" because it disables all error messages. Can you describe a situation where there is no match?

 

[tendosai]

It is not good practice to use "on error go to" because it disables all error messages. Can you describe a situation where there is no match?

yes. i used this

.Range("A1").CurrentRegion.AutoFilter 2, ">=" & desWS.Range("B4").Value, xlAnd, "<=" & desWS.Range("B5").Value

to filter the date of attendance. so when filter and there is empty .. it will throw error to SN.value

 

[mumps]

Can you post the entire code so that I can see where in the code you inserted that line?

 

[tendosai]

Can you post the entire code so that I can see where in the code you inserted that line?

here help check ...

Sub CalculateScore()
Range("A8:J999").ClearContents
    Application.ScreenUpdating = False
    Dim LastRow As Long, team As Range, srcWS As Worksheet, desWS As Worksheet, struct As Worksheet, lRow As Long
    Dim arr As Variant, SN As Range, total As Long, Math As Long, PE As Long, Physic As Long, Chemistry   As Long, Social As Long, Bio As Long
    Set srcWS = Sheets("Raw_Report")
    Set desWS = Sheets("Template")
    Set struct = Sheets("Structure")
    Dim row_count As Long
    LastRow = struct.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set team = struct.Rows(1).Find(desWS.Range("H1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not team Is Nothing Then
        arr = Application.Transpose(struct.Range(team.Address).Resize(LastRow).Value)
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 2, ">=" & desWS.Range("B4").Value, xlAnd, "<=" & desWS.Range("B5").Value
            .Range("A1").CurrentRegion.AutoFilter 4, arr, xlFilterValues
            With CreateObject("Scripting.Dictionary")
                On Error GoTo endProc
For Each SN In srcWS.Range("C2:C" & lRow).SpecialCells(xlCellTypeVisible)
                    If Not .exists(SN.Value) Then
                        .Add SN.Value, Nothing
                        With srcWS.Range("A1")
                            .CurrentRegion.AutoFilter 3, SN
                            Math = Application.WorksheetFunction.Sum(.Range("E2:E" & lRow).SpecialCells(xlCellTypeVisible))
                            PE = Application.WorksheetFunction.Sum(.Range("F2:F" & lRow).SpecialCells(xlCellTypeVisible))
                            Physic = Application.WorksheetFunction.Sum(.Range("G2:G" & lRow).SpecialCells(xlCellTypeVisible))
                            Chemistry = Application.WorksheetFunction.Sum(.Range("H2:H" & lRow).SpecialCells(xlCellTypeVisible))
                            Social = Application.WorksheetFunction.Sum(.Range("I2:I" & lRow).SpecialCells(xlCellTypeVisible))
                            Bio = Application.WorksheetFunction.Sum(.Range("J2:J" & lRow).SpecialCells(xlCellTypeVisible))
                            total = Application.WorksheetFunction.Sum(.Range("K2:K" & lRow).SpecialCells(xlCellTypeVisible))
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 9).Value = Array(SN, SN.Offset(, 1), Math, PE, Physic, Chemistry, Social, Bio, total)
                            End With
                        End With
                    End If
                Next SN
            End With
            .Range("A1").AutoFilter
        End With
    End If
    With desWS.Range("A8")
        row_count = Range("B" & Rows.Count).End(xlUp).Row - 7
        If row_count = 1 Then
        .Value = "1"
        ElseIf row_count > 1 Then
       .Value = "1"
       .AutoFill Destination:=Range("A8").Resize(Range("B" & Rows.Count).End(xlUp).Row - 7), Type:=xlFillSeries
       End If
    End With
    Application.ScreenUpdating = True
Exit Sub
endProc:
MsgBox "Error"
End Sub

 

[mumps]

Try:

Sub CalculateScore()
    Application.ScreenUpdating = False
    Dim LastRow As Long, team As Range, srcWS As Worksheet, desWS As Worksheet, struct As Worksheet, lRow As Long
    Dim arr As Variant, SN As Range, total As Long, Math As Long, PE As Long, Physic As Long, Chemistry   As Long, Social As Long, Bio As Long
    Set srcWS = Sheets("Raw Report")
    Set desWS = Sheets("Template")
    Set struct = Sheets("Structure")
    LastRow = struct.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    desWS.UsedRange.Offset(7).ClearContents
    Set team = struct.Rows(1).Find(desWS.Range("H1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not team Is Nothing Then
        arr = Application.Transpose(struct.Range(team.Address).Resize(LastRow).Value)
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 2, ">=" & desWS.Range("B4").Value, xlAnd, "<=" & desWS.Range("B5").Value
            .Range("A1").CurrentRegion.AutoFilter 4, arr, xlFilterValues
            RowCount = .[subtotal(103,A:A)] - 1
        End With
        If RowCount > 0 Then
            With CreateObject("Scripting.Dictionary")
                For Each SN In srcWS.Range("C2:C" & lRow).SpecialCells(xlCellTypeVisible)
                    If Not .exists(SN.Value) Then
                        .Add SN.Value, Nothing
                        With srcWS.Range("A1")
                            .CurrentRegion.AutoFilter 3, SN
                            Math = Application.WorksheetFunction.Sum(.Range("E2:E" & lRow).SpecialCells(xlCellTypeVisible))
                            PE = Application.WorksheetFunction.Sum(.Range("F2:F" & lRow).SpecialCells(xlCellTypeVisible))
                            Physic = Application.WorksheetFunction.Sum(.Range("G2:G" & lRow).SpecialCells(xlCellTypeVisible))
                            Chemistry = Application.WorksheetFunction.Sum(.Range("H2:H" & lRow).SpecialCells(xlCellTypeVisible))
                            Social = Application.WorksheetFunction.Sum(.Range("I2:I" & lRow).SpecialCells(xlCellTypeVisible))
                            Bio = Application.WorksheetFunction.Sum(.Range("J2:J" & lRow).SpecialCells(xlCellTypeVisible))
                            total = Application.WorksheetFunction.Sum(.Range("K2:K" & lRow).SpecialCells(xlCellTypeVisible))
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 9).Value = Array(SN, SN.Offset(, 1), Math, PE, Physic, Chemistry, Social, Bio, total)
                            End With
                        End With
                    End If
                Next SN
            End With
            With desWS.Range("A8")
                .Value = "1"
                .AutoFill Destination:=Range("A8").Resize(Range("B" & Rows.Count).End(xlUp).Row - 7), Type:=xlFillSeries
            End With
        End If
        srcWS.Range("A1").AutoFilter
    End If
    Application.ScreenUpdating = True
End Sub

 

[tendosai]

thank you sir.
A small request if u dont mind,

desWS.UsedRange.Offset(7).ClearContents

how to adjust this code so it only clear content of what in the "A" to "K". i have some note at other column. but it got delete as well ... lol.

 

[mumps]

If the notes in the other column are related to or reference the data that is pasted in columns A to K, then clearing the contents A:K and then pasting new new in A:K the relationship or reference will no longer apply. What is the purpose of the notes in the other column? Can the notes be placed on a different sheet?

 

[tendosai]

not relate actually .. but some sort of note taking when send out report

 

[mumps]

Try:

Sub CalculateScore()
    Application.ScreenUpdating = False
    Dim LastRow As Long, team As Range, srcWS As Worksheet, desWS As Worksheet, struct As Worksheet, lRow As Long, lRow2 As Long
    Dim arr As Variant, SN As Range, total As Long, Math As Long, PE As Long, Physic As Long, Chemistry   As Long, Social As Long, Bio As Long
    Set srcWS = Sheets("Raw Report")
    Set desWS = Sheets("Template")
    Set struct = Sheets("Structure")
    LastRow = struct.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    desWS.Range("A8:K" & lRow2).ClearContents
    Set team = struct.Rows(1).Find(desWS.Range("H1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not team Is Nothing Then
        arr = Application.Transpose(struct.Range(team.Address).Resize(LastRow).Value)
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 2, ">=" & desWS.Range("B4").Value, xlAnd, "<=" & desWS.Range("B5").Value
            .Range("A1").CurrentRegion.AutoFilter 4, arr, xlFilterValues
            RowCount = .[subtotal(103,A:A)] - 1
        End With
        If RowCount > 0 Then
            With CreateObject("Scripting.Dictionary")
                For Each SN In srcWS.Range("C2:C" & lRow).SpecialCells(xlCellTypeVisible)
                    If Not .exists(SN.Value) Then
                        .Add SN.Value, Nothing
                        With srcWS.Range("A1")
                            .CurrentRegion.AutoFilter 3, SN
                            Math = Application.WorksheetFunction.Sum(.Range("E2:E" & lRow).SpecialCells(xlCellTypeVisible))
                            PE = Application.WorksheetFunction.Sum(.Range("F2:F" & lRow).SpecialCells(xlCellTypeVisible))
                            Physic = Application.WorksheetFunction.Sum(.Range("G2:G" & lRow).SpecialCells(xlCellTypeVisible))
                            Chemistry = Application.WorksheetFunction.Sum(.Range("H2:H" & lRow).SpecialCells(xlCellTypeVisible))
                            Social = Application.WorksheetFunction.Sum(.Range("I2:I" & lRow).SpecialCells(xlCellTypeVisible))
                            Bio = Application.WorksheetFunction.Sum(.Range("J2:J" & lRow).SpecialCells(xlCellTypeVisible))
                            total = Application.WorksheetFunction.Sum(.Range("K2:K" & lRow).SpecialCells(xlCellTypeVisible))
                            With desWS
                                lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                                .Range("B" & lRow).Resize(, 9).Value = Array(SN, SN.Offset(, 1), Math, PE, Physic, Chemistry, Social, Bio, total)
                            End With
                        End With
                    End If
                Next SN
            End With
            With desWS.Range("A8")
                .Value = "1"
                .AutoFill Destination:=Range("A8").Resize(Range("B" & Rows.Count).End(xlUp).Row - 7), Type:=xlFillSeries
            End With
        End If
        srcWS.Range("A1").AutoFilter
    End If
    Application.ScreenUpdating = True
End Sub

 

[tendosai]

? a thousand thank