Nhờ các bác viết code tính điểm trung bình các môn cho các lớp. Em cảm ơn nhiều! (1 người xem)

[trungtamcnc]

Trong file em đã dùng công thức để tính, các bác viết hộ code tính ra các giá trị đó, số lớp thay đổi theo năm ạ! Em cảm ơn nhiều ạ!

 

[befaint]

Cái này dùng công thức là được rồi bạn.

 

[trungtamcnc]

Cái này dùng công thức là được rồi bạn.

Cảm ơn bác đã quan tâm, công thức của bác đã bao quát được rồi ạ. Nhưng em muốn có code để khi chia sẻ sheet đỡ phải nhiều thao tác và file dữ liệu của em còn đúng chỗ này không code được thôi.

 

[befaint]

Cảm ơn bác đã quan tâm, công thức của bác đã bao quát được rồi ạ. Nhưng em muốn có code để khi chia sẻ sheet đỡ phải nhiều thao tác và file dữ liệu của em còn đúng chỗ này không code được thôi.

Vậy bạn chờ ai đó rảnh làm cho bạn rồi.

 

[trungtamcnc]

Vậy bạn chờ ai đó rảnh làm cho bạn rồi.

Công thức của bác rất hay, nhưng bác xem lại chỗ môn Sử, Địa, GD. Không có kết quả ạ!
Của bác:


Của em:

 

[VetMini]

Bạn làm nghề giáo dục thì đáng lẽ bạn phải biết là không nên nhờ từ a đến z.
Bạn muốn code VBA thì bạn tự code, chỗ nào bí thì đưa code lên nhờ chỉnh sửa giùm.

 

[befaint]

Công thức của bác rất hay, nhưng bác xem lại chỗ môn Sử, Địa, GD. Không có kết quả ạ!

Bạn tải lại file nhé.

 

[trungtamcnc]

Bạn làm nghề giáo dục thì đáng lẽ bạn phải biết là không nên nhờ từ a đến z.
Bạn muốn code VBA thì bạn tự code, chỗ nào bí thì đưa code lên nhờ chỉnh sửa giùm.

Nhờ bác động viên mà em viết được rồi:
Option Explicit
Sub dem()
Dim t As Integer
'Bien cot
Dim i As Integer
'Bien dong
Dim j As Integer
t = Sheet4.Cells(Rows.Count, 1).End(xlUp).row
Sheet4.Select
For j = 18 To 29
For i = 2 To 10
On Error Resume Next
Sheet3.Cells(j, i) = Application.WorksheetFunction.Round(Application.WorksheetFunction.AverageIf(Sheet4.range(Cells(3, 30), Cells(t, 30)), Sheet3.Cells(j, 1), Sheet4.range(Cells(3, i + 7), Cells(t, i + 7))), 2)
Next i
Next j
Sheet3.Select
End Sub
Nhưng chỗ các lớp em phải nhập tay.

 

[snow25]

Công thức của bác rất hay, nhưng bác xem lại chỗ môn Sử, Địa, GD. Không có kết quả ạ!
Của bác:
View attachment 276833

Của em:
View attachment 276834

Thử code này.

Sub abc()
   Dim i As Long, lr As Long, dic As Object, arr, kq, dk As String, a As Long, b As Long, tong As Double, dem As Integer, j As Integer
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("Sh_01")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:AD" & lr).Value
        For i = 2 To UBound(arr)
            For j = 9 To 19
                If Len(arr(i, j)) > 0 Then
                   dk = arr(i, 30) & "#" & arr(1, j)
                   If Not dic.exists(dk) Then
                      dic.Add dk, Array(arr(i, j), 1)
                   Else
                      dic.Item(dk) = Array(dic.Item(dk)(0) + arr(i, j), dic.Item(dk)(1) + 1)
                   End If
                End If
           Next j
      Next i
  End With
  With Sheets("Baocaoso")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 17 Then .Range("B17:J" & lr).ClearContents
       arr = .Range("A16:J" & lr).Value
       For j = 2 To 10
       tong = 0
       dem = 0
           For i = 3 To UBound(arr)
               dk = arr(i, 1) & "#" & arr(1, j)
               If dic.exists(dk) Then
                  arr(i, j) = Format(dic.Item(dk)(0) / dic.Item(dk)(1), "#.##")
                  tong = tong + arr(i, j)
                  dem = dem + 1
               End If
           Next i
           If dem Then arr(2, j) = tong / dem
      Next j
      .Range("A16:J" & lr).Value = arr
End With
Set dic = Nothing
End Sub

 

[trungtamcnc]

Cảm ơn bác @snow25 , tốc độ code chạy quá nhanh ạ!

 

[VetMini]

Thử code này.
....
[/CODE]

Khi dùng đít sần mà cần tính nhiều hơn một trị tổng thì dùng user defined type dễ hơn.

Lý tưởng:

Private Type GopDuLieu
tong As Double
dem As Long
End Type

Trong code
Dim a As GopDuLieu
a = Dic("abc")
a.tong = a.tong + số mới
a.dem = a.dem + 1
Dic("abc") = a

Thực tế (phủ phàng):

Error -> Đít sần không nhận UDT. Lý do là UDT không thể ép kiểu để nhét vào Đít sần.

Vá đắp, chữa cháy:
Dùng một class module để giả như UDT

Nhưng như vậy thì rối rắm hơn dùng Array. Chả bõ công.

Riêng bài này thì có cách khác để thực hiện: dùng mảng và lưu chỉ số trên Dic

1. Redim mảng kết quả đầu ra nhiều hơn đầu ra 2 cột
2. hai cột ấy dùng chứa tổng và đếm

Dim cTong As Long, cDem As Long
cTong = soCot + 1
cDem = soCot + 2
ReDim b(1 To MaxDong, 1 To soCot + 2)
idx = Dic("abc")
b(idx, cTong) = b(idx, cTong) + số mới
b(idx, cDem) = b(idx, cDem) + 1

Lúc chép lại:
rg.ReSize(tongDong, soCot) = b

 

[SA_DQ]

Nhờ bác động viên mà em viết được rồi:
. . . . .

Bạn chủ bài đăng có thể tham khảo lúc rỗi:

Sub TKeDiemTB()
 Dim T As Integer                                   'Bién Dòng '
 Dim I As Integer                                   'Biên Côt  '
 Dim J As Integer
 Dim WF As Object, Sh As Worksheet:                 On Error GoTo LoiCT

 Set Sh = Sheet4:                                   Sh.Select
 T = Sh.Cells(Rows.Count, 1).End(xlUp).Row
 Set WF = Application.WorksheetFunction
 For J = 18 To 29
    For I = 2 To 10
   '     On Error Resume Next   '
        Sheet3.Cells(J, I) = _
            WF.Round(WF.AverageIf(Sh.Range(Cells(3, 30), Cells(T, 30)), Sheet3.Cells(J, 1), Sh.Range(Cells(3, I + 7), Cells(T, I + 7))), 2)
    Next I
 Next J
Sheet3.Select
Err_:                                               Exit Sub
LoiCT:
    If Err = 1004 Then
        Resume Next
    Else
        MsgBox Error, , Err:                        GoTo Err_
    End If
End Sub

Tuy nhiên trong macro này còn sai sót, như chưa xóa kết quả do lần chạy (code) trước đưa lại,. . . .

 

[trungtamcnc]

Bạn chủ bài đăng có thể tham khảo lúc rỗi:

Sub TKeDiemTB()
 Dim T As Integer                                   'Bién Dòng '
 Dim I As Integer                                   'Biên Côt  '
 Dim J As Integer
 Dim WF As Object, Sh As Worksheet:                 On Error GoTo LoiCT

 Set Sh = Sheet4:                                   Sh.Select
 T = Sh.Cells(Rows.Count, 1).End(xlUp).Row
 Set WF = Application.WorksheetFunction
 For J = 18 To 29
    For I = 2 To 10
   '     On Error Resume Next   '
        Sheet3.Cells(J, I) = _
            WF.Round(WF.AverageIf(Sh.Range(Cells(3, 30), Cells(T, 30)), Sheet3.Cells(J, 1), Sh.Range(Cells(3, I + 7), Cells(T, I + 7))), 2)
    Next I
 Next J
Sheet3.Select
Err_:                                               Exit Sub
LoiCT:
    If Err = 1004 Then
        Resume Next
    Else
        MsgBox Error, , Err:                        GoTo Err_
    End If
End Sub

Tuy nhiên trong macro này còn sai sót, như chưa xóa kết quả do lần chạy (code) trước đưa lại,. . . .

Cảm ơn bác. Đúng là có vấn đề về lỗi 1004 ạ.