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

T

tendosai

New Member
Joined
Mar 14, 2022
Messages
26
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
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
 

Attachments

  • Untitled.png
    Untitled.png
    27.3 KB · Views: 24
Sort by date Sort by votes
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?
 
Upvote 0

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
mumps said:
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?
Click to expand...
yes. i used this
VBA Code: 
.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
 
Upvote 0
Can you post the entire code so that I can see where in the code you inserted that line?
 
Upvote 0
Can you post the entire code so that I can see where in the code you inserted that line?
Click to expand...
here help check ...

VBA Code: 
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
 
Upvote 0
Try:
VBA Code: 
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
 
Upvote 0
Solution
thank you sir.
A small request if u dont mind,
VBA Code: 
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.
 
Upvote 0
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?
 
Upvote 0
not relate actually .. but some sort of note taking when send out report
 
Upvote 0
Try:
VBA Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Excel data from one sheet, copy cells from row i'm working on to excel 'form' based on cell value
Replies
2
Views
529
asiuol84
A
A
  • Question Question
How to Insert another loop for inputting multiple receiver name in an Email based on criteria
Replies
3
Views
673
portews
P
J
  • Question Question
VBA copy data from multiple workbooks based on criteria
Replies
6
Views
2K
Jendjieh
J
U
  • Question Question
Rename file Based on Cell value and Criteria
2
Replies
13
Views
12K
unknownymous
U
I
  • Question Question
Power Query - Split Master Table into Multiple table as per value in a column (Dynamic)
Replies
0
Views
7K
ialwayscapital
I

Forum statistics

Threads
1,223,893
Messages
6,175,249
Members
452,623
Latest member
Techenthusiast

Share this page

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
Back
Top