Một lần nữa xin cảm ơn bạn rất nhiều. Mình tìm trên mạng bài của các anh chị trên diễn đàn thấy có nhiều bài rất là hay bạn có thể giải thích thêm cho mình code này được không ah.
Code:
Option Explicit
Option Base 1
Dim nDong As Long, endR As Long, k As Long
Dim iMon As Long
Dim shName As String
Dim WF As WorksheetFunction
Dim HS11, HS21, Thi1, HS12, HS22, Thi2
Const fR As Long = 5
Sub TinhDiemTN() ' Sub cua Ptm0412
Dim Arr() As Variant
Dim MonArr
Dim t As Variant
t = Timer
MonArr = Array("TOAN", "LY", "HOA", "SINH", "TIN", "VAN", "SU", "DIA", "ANH", "GDCD", "CNGHE", "GDQP")
Set WF = WorksheetFunction
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim SumHS1, SumHS2, iCount1, iCount2, iCol
For iMon = 1 To UBound(MonArr)
shName = MonArr(iMon)
With Sheets(shName)
endR = .Cells(10000, 1).End(xlUp).Row
ReDim Arr(endR - fR + 1, 3)
ReDim HS11(endR - fR + 1, 6)
ReDim HS21(endR - fR + 1, 5)
ReDim HS12(endR - fR + 1, 6)
ReDim HS22(endR - fR + 1, 5)
ReDim Thi1(endR - fR + 1, 1)
ReDim Thi2(endR - fR + 1, 1)
HS11 = .Range("F" & fR & ":K" & endR)
HS21 = .Range("L" & fR & "
" & endR)
HS12 = .Range("R" & fR & ":W" & endR)
HS22 = .Range("X" & fR & ":AB" & endR)
Thi1 = .Range("Q" & fR & ":Q" & endR)
Thi2 = .Range("AC" & fR & ":AC" & endR)
For k = 1 To endR - fR + 1
'diem HK1'
For iCol = 1 To 6
SumHS1 = SumHS1 + HS11(k, iCol)
iCount1 = iCount1 + IIf(HS11(k, iCol) > 0, 1, 0)
Next
For iCol = 1 To 5
SumHS2 = SumHS2 + HS21(k, iCol) * 2
iCount2 = iCount2 + IIf(HS21(k, iCol) > 0, 2, 0)
Next
If SumHS1 = 0 Or SumHS2 = 0 Then GoTo bien
Arr(k, 1) = (SumHS1 + SumHS2 + Thi1(k, 1) * 3) / (iCount1 + iCount2 + 3)
'diem HK2'
SumHS1 = 0: SumHS2 = 0: iCount1 = 0: iCount2 = 0
For iCol = 1 To 6
SumHS1 = SumHS1 + HS12(k, iCol)
iCount1 = iCount1 + IIf(HS12(k, iCol) > 0, 1, 0)
Next
For iCol = 1 To 5
SumHS2 = SumHS2 + HS22(k, iCol) * 2
iCount2 = iCount2 + IIf(HS22(k, iCol) > 0, 2, 0)
Next
If SumHS1 = 0 Or SumHS2 = 0 Then GoTo bien
Arr(k, 2) = (SumHS1 + SumHS2 + Thi2(k, 1) * 3) / (iCount1 + iCount2 + 3)
Arr(k, 3) = Round((2 * Arr(k, 2) + Arr(k, 1)) / 3, 1)
bien:
Next k
'gan vao'
.Range("AD" & fR & ":AF" & endR) = Arr
End With
Next iMon '
Set WF = Nothing
Set HS11 = Nothing: Set HS21 = Nothing
Set HS12 = Nothing: Set HS22 = Nothing
Set Thi1 = Nothing: Set Thi2 = Nothing
With Application
.ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
MsgBox Timer - t
End Sub
Đây là code của bạn Ptm0412 trong bài của Bate mình kiểm tra thì thấy code này là nhanh nhất
dữ liệu của Ba Tê (bảng 1) Mình muốn chuyển sang dữ liệu kiểu này thì code trên phải chuyển lại như thế nào hả các bạn xin mọi người giúp đở cảm ơn các bạn nhiều
du74 liệu của mình (bảng 2)
