em vẫn muốn hướng dẫn sửa từ code này ạ
Chỉ chấp nhận 1 số lẽ
Sub LargeNumeFilter()
Dim sArr(), Res(), Arr(), tmp
Dim sRow&, iRnk&, i&, k&, ik&, q&
Dim fDay As Date, eDay As Date, maSV$, Diem&
On Error Resume Next
With Sheet2
fDay = .Range("D1").Value 'Ngay dau
eDay = .Range("D2").Value 'Ngay cuoi
.Range("A5:E500").ClearContents 'Xoa ket qua
End With
If Err.Number > 0 Or fDay > eDay Then 'Kiem tra tinh hop le ngay xuat bao cao
MsgBox ("Xem lai dieu kien ngay thi Tu ... Den ...")
Err.Clear
Exit Sub
End If
iRnk = Application.InputBox(prompt:="Nhap Diem Cao thu:", Type:=1) 'Nhap tuy chon Diem Cao thu
If iRnk = 0 Then Exit Sub 'Khong nhap tuy chon thoat sub
With Sheet1
sArr = .Range("E2", .Range("N" & Rows.Count).End(xlUp)).Value 'Tao mang du lieu
End With
sRow = UBound(sArr) 'So dong du lieu
ReDim Arr(0 To 1000) 'Mang "Lan Thi" voi thu tu dong la "Diem" tu 0 den 100
ReDim Res(1 To sRow, 1 To 5) 'Mang Ket Qua
With CreateObject("Scripting.Dictionary")
For i = 1 To sRow
If fDay <= sArr(i, 6) And eDay >= sArr(i, 6) Then
maSV = sArr(i, 1) 'Ten Sinh Vien
Diem = sArr(i, 10) * 10 'Diem so cua sinh vien
If .Exists(maSV) = False Then 'Loc sinh vien duy nhat
k = k + 1
Res(k, 1) = k 'So thu tu sinh vien
Res(k, 2) = maSV 'Tính lai Ten Sinh Vien trong file thuc te
.Add maSV, Arr 'Add sinh vien vao Dic de loai trung, voi Item la mang Diem
End If
tmp = .Item(maSV) 'Mang "Thu tu dong cua sArr"
'Gan thu tu dong i vào dong "Diem". Chon 1 trong 2 lenh duoi
tmp(Diem) = i 'Lay lan thi cuoi
'If tmp(Diem) = Empty Then tmp(Diem) = i 'Lay lan thi dau
.Item(maSV) = tmp 'Gan tmp vào Item cua Dic
End If
Next i
If k Then 'Neu co danh sach sinh vien
For i = 1 To k
tmp = .Item(Res(i, 2)) 'Mang "Lan Thi" cua sinh vien thu i
q = 0 'Bien dem
For Diem = 1000 To 0 Step -1
If tmp(Diem) <> Empty Then q = q + 1 ' Diem Cao thu q
If q = iRnk Then 'Neu Diem Cao thu thoa dieu kien
ik = tmp(Diem) ' thu tu dong cua sArr
Res(i, 3) = sArr(ik, 6) 'Ngay thi
Res(i, 4) = sArr(ik, 7) 'Gio thi
Res(i, 5) = Diem / 10 ' Diem Cao thu iRnk
Exit For 'Thoat vong lap: For Diem = 100 To 0 Step -1
End If
Next Diem
Next i
Sheet2.Range("A5").Resize(k, 5) = Res 'Gan ket qua
End If
End With
End SubVới file là điểm này thì 1 số lẻ là ok ạ. Nhưng em theo cách hiểu của em thì với mỗi số lẻ phía sau thì e thêm 1 số 0. Em thử với file có 5 số lẻ thì thấy code chậm hơn nhiều.
Vậy với code này có cách nào tối ưu hơn ko ạ?
Nếu số lẻ nhiều mảng điểm sẽ lớn chạy nhiều lần sẽ chậm, dùng SortList ổn hơn
Tức là sắp xếp theo thứ tự rồi mới quét ấy ạ
Chạy code
Sub LargeNumeFilter()
Dim sArr(), Res(), Arr(), bK As Boolean
Dim sRow&, iRnk&, i&, k&, q&
Dim fDay As Date, eDay As Date, maSV$, Diem
On Error Resume Next
With Sheet2
fDay = .Range("D1").Value 'Ngay dau
eDay = .Range("D2").Value 'Ngay cuoi
.Range("A5:E500").ClearContents 'Xoa ket qua
End With
If Err.Number > 0 Or fDay > eDay Then 'Kiem tra tinh hop le ngay xuat bao cao
MsgBox ("Xem lai dieu kien ngay thi Tu ... Den ...")
Err.Clear
Exit Sub
End If
iRnk = Application.InputBox(prompt:="Nhap Diem Cao thu:", Type:=1) 'Nhap tuy chon Diem Cao thu
If iRnk = 0 Then Exit Sub 'Khong nhap tuy chon thoat sub
With Sheet1
i = .Range("E" & Rows.Count).End(xlUp).Row 'Dong cuoi sheet1
Arr = .Range("E2:N" & i).Value 'Tao mang du lieu Goc
.Range("E2:N" & i).Sort .Range("E2"), 1, .Range("N2"), , 2, Header:=xlNo 'Sort du lieu
sArr = .Range("E2:N" & i + 1).Value 'Tao mang du lieu da Sort
.Range("E2:N" & i).Value = Arr 'Tra ve du lieu goc
End With
sRow = UBound(sArr) 'So dong du lieu
ReDim Res(1 To sRow, 1 To 5) 'Mang Ket Qua
For i = 1 To sRow - 1
If fDay <= sArr(i, 6) And eDay >= sArr(i, 6) Then
If maSV <> sArr(i, 1) Then 'Ten Sinh Vien
maSV = sArr(i, 1)
k = k + 1
Res(k, 1) = k 'So thu tu sinh vien
Res(k, 2) = maSV 'Tính lai Ten Sinh Vien trong file thuc te
Diem = sArr(i, 10) + 1 'Diem so cua sinh vien
q = 0
bK = True
End If
If bK = True Then
If Diem > sArr(i, 10) Then
Diem = sArr(i, 10)
q = q + 1
If q = iRnk Then 'Neu Diem Cao thu thoa dieu kien
Res(k, 3) = sArr(i, 6) 'Ngay thi
Res(k, 4) = sArr(i, 7) 'Gio thi
Res(k, 5) = Diem ' Diem Cao thu iRnk
bK = False 'Thoat vong lap: For Diem = 100 To 0 Step -1
End If
End If 'Gan tmp vào Item cua Dic
End If
End If
Next i
If k Then 'Neu co danh sach sinh vien
Sheet2.Range("A5").Resize(k, 5) = Res 'Gan ket qua
End If
End Sub
Bạn thử.
Sub laydiem()
Const so As Integer = 5
Dim arr, kq, a As Long, olit As Object, ngaydau As Long, ngaycuoi As Long, lr As Long, dk As String, diem As Double
Dim i As Long, T, k As Integer, dic As Object, b As Long, s1 As String, s2 As String, mang1, mang2, j As Long, m As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet2")
ngaydau = .Range("D1").Value
ngaycuoi = .Range("d2").Value
.Range("A5:E500").ClearContents
End With
With Sheets("sheet1")
lr = .Range("E" & Rows.Count).End(xlUp).Row
If lr < 2 Then Exit Sub
arr = .Range("E2:N" & lr).Value
ReDim kq(1 To UBound(arr), 1 To 5)
For i = 1 To UBound(arr)
If ngaydau <= CLng(arr(i, 6)) And ngaycuoi >= CLng(arr(i, 6)) Then
dk = arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, Array("#" & arr(i, 10), "#" & i)
Else
s1 = dic.Item(dk)(0) & "#" & arr(i, 10)
s2 = dic.Item(dk)(1) & "#" & i
dic.Item(dk) = Array(s1, s2)
End If
End If
Next i
For Each T In dic.keys
b = 1
s1 = dic.Item(T)(0)
s2 = dic.Item(T)(1)
mang1 = Split(s1, "#")
mang2 = Split(s2, "#")
k = UBound(mang1)
For i = 1 To k
For j = k - 1 To i Step -1
If mang1(j) < mang1(j + 1) Then
diem = mang1(j + 1)
mang1(j + 1) = mang1(j)
mang1(j) = diem
End If
Next j
If i > 1 Then
If mang1(i) < mang1(i - 1) Then b = b + 1
End If
If b = so Then
diem = mang1(i)
mang1 = Split(s1, "#")
For m = 1 To k
If mang1(m) = diem Then
a = a + 1
kq(a, 1) = a
kq(a, 2) = arr(mang2(m), 1)
kq(a, 3) = arr(mang2(m), 6)
kq(a, 4) = arr(mang2(m), 7)
kq(a, 5) = arr(mang2(m), 10)
End If
Next m
Exit For
End If
Next i
Next
End With
With Sheets("sheet2")
If a Then .Range("A5:E5").Resize(a).Value = kq
End With
End SubChuẩn rồi ạ, qua những code anh đã giúp em ngẫm ra được rất nhiều điều, cảm ơn anh ạ.
Mình chạy code này nó ko hoạt động, đứng im luôn bạn ạ
