Nhờ giúp đỡ code lọc theo nhiều điều kiện.

phuocam

Thành viên mới
Tham gia ngày
16 Tháng năm 2013
Bài viết
2,393
Được thích
3,173
Điểm
560
Dùng AdvancedFilter thì Trình Văn Vịnh lớn 1 hay lớn 2 đều 86.
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
333
Được thích
41
Điểm
685
Thấy cấu truc lại khác với file ban đầu.
Đúng rồi ạ. Ý em là muốn sửa code từ file ban đầu theo file này để e học. Nhưng sửa mãi ko thành. Nên e muốn nhờ tác giả code sửa để e so sánh, khi đó e sẽ hiểu code dễ hơn ạ. Đây đơn thuần chỉ là e muốn học thêm, còn nhu cầu của e thì file ban đầu là ok rồi.
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,272
Được thích
11,676
Điểm
1,560
Hi bác, em ngồi mò mấy ngày mà vẫn ko hiểu hết được code của bác. Em thử sửa thành cấu trúc file data kiểu khác rồi sửa code để được theo mong muốn nhưng không được. Em up file mới lên đây, nhờ bác code lại giúp theo cái này để em so sánh sự thay đổi giữa 2 code em rút ra được điều mình cần ạ?
Dữ liệu này đang là 1 lớp, bác code giúp em nếu là hàng chục lớp với hàng ngàn học sinh ạ.
Làm sao phân biệt được SV khác nhau nhưng trùng tên?
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,272
Được thích
11,676
Điểm
1,560
Vâng ạ. Anh sửa giúp theo cả 2 hướng đc ko ạ. 1 là y nguyên như file em vừa gửi, 2 là thêm cái cột mã sv. Như vậy e sẽ biết thêm đc nhiều hơn.
Cột ngày và cột giờ thi nếu trùng điểm cao nhất sẽ rất khó nhìn, nên tính theo phương án khác
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
333
Được thích
41
Điểm
685
Dữ liệu chỉ 1 môn hay nhiều môn? Nếu nhiều môn thì sao?
Hiện tại em chỉ làm cho từng môn ạ. Từ cái code theo form mới này a giúp em, em sẽ cố gắng hiểu và mò để làm cho nhiều môn, nếu ko thể được em sẽ hỏi tiếp, như thế em sẽ học và nhớ đc lâu hơn ạ.
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,272
Được thích
11,676
Điểm
1,560
Có thể bỏ cái vụ trùng đi cũng đc ạ, nếu cao nhất thì chỉ lấy 1 thôi ạ.
Hiện tại em chỉ làm cho từng môn ạ. Từ cái code theo form mới này a giúp em, em sẽ cố gắng hiểu và mò để làm cho nhiều môn, nếu ko thể được em sẽ hỏi tiếp, như thế em sẽ học và nhớ đc lâu hơn ạ.
Xem code
Mã:
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 100)                                                '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)                                              '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 = 100 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                                         ' 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 Sub
 

File đính kèm

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,464
Được thích
2,322
Điểm
360
Xem code
Mã:
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 100)                                                '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)                                              '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 = 100 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                                         ' 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 Sub
Bài này nếu mình sắp xếp theo điểm rồi lấy vị trí có được không anh nhỉ.
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
333
Được thích
41
Điểm
685
Xem code
Mã:
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 100)                                                '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)                                              '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 = 100 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                                         ' 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 Sub
Ở kết quả nếu em nhập điểm có phẩy nó đang tự động làm tròn, ví dụ e nhập 88,4 nó làm tròn thành 88, nhập 88,6 nó làm tròn thành 89, em muốn giữ nguyên như mình nhập vào thì làm sao ạ
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,464
Được thích
2,322
Điểm
360
Ở kết quả nếu em nhập điểm có phẩy nó đang tự động làm tròn, ví dụ e nhập 88,4 nó làm tròn thành 88, nhập 88,6 nó làm tròn thành 89, em muốn giữ nguyên như mình nhập vào thì làm sao ạ
Bạn thử code này nhé.
Mã:
Sub laydiem()
    Const so As Integer = 1
    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
    Set olit = CreateObject("System.Collections.SortedList")
    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
               diem = arr(i, 10)
               If Not olit.contains(diem) Then
                  olit.Add diem, i
               Else
                  olit.Item(diem) = olit.Item(diem) & "#" & i
               End If
           End If
       Next i
       If olit.Count = 0 Then Exit Sub
       For k = olit.Count - 1 To 0 Step -1
           For Each T In Split(olit.getbyindex(k), "#")
               dk = arr(T, 1)
               If Not dic.exists(dk) Then
                  dic.Add dk, Array(1, arr(T, 10))
               End If
                  b = dic.Item(dk)(0)
                  diem = dic.Item(dk)(1)
                  If diem > arr(T, 10) Then
                     b = b + 1
                  End If
                  dic.Item(dk) = Array(b, arr(T, 10))
                  If b = so Then
                     a = a + 1
                     kq(a, 1) = a
                     kq(a, 2) = arr(T, 1)
                     kq(a, 3) = arr(T, 6)
                     kq(a, 4) = arr(T, 7)
                     kq(a, 5) = arr(T, 10)
                  End If
           Next T
       Next k
  End With
  With Sheets("sheet2")
       If a Then .Range("A5:E5").Resize(a).Value = kq
  End With
End Sub
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
333
Được thích
41
Điểm
685
Bạn thử code này nhé.
Mã:
Sub laydiem()
    Const so As Integer = 1
    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
    Set olit = CreateObject("System.Collections.SortedList")
    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
               diem = arr(i, 10)
               If Not olit.contains(diem) Then
                  olit.Add diem, i
               Else
                  olit.Item(diem) = olit.Item(diem) & "#" & i
               End If
           End If
       Next i
       If olit.Count = 0 Then Exit Sub
       For k = olit.Count - 1 To 0 Step -1
           For Each T In Split(olit.getbyindex(k), "#")
               dk = arr(T, 1)
               If Not dic.exists(dk) Then
                  dic.Add dk, Array(1, arr(T, 10))
               End If
                  b = dic.Item(dk)(0)
                  diem = dic.Item(dk)(1)
                  If diem > arr(T, 10) Then
                     b = b + 1
                  End If
                  dic.Item(dk) = Array(b, arr(T, 10))
                  If b = so Then
                     a = a + 1
                     kq(a, 1) = a
                     kq(a, 2) = arr(T, 1)
                     kq(a, 3) = arr(T, 6)
                     kq(a, 4) = arr(T, 7)
                     kq(a, 5) = arr(T, 10)
                  End If
           Next T
       Next k
  End With
  With Sheets("sheet2")
       If a Then .Range("A5:E5").Resize(a).Value = kq
  End With
End Sub
1575962850620.png
Báo lỗi bạn ạ
 
Top Bottom