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

Liên hệ QC

pinklove

Thành viên thường trực
Tham gia
21/1/08
Bài viết
336
Được thích
42
Mình có file Điểm như đính kèm, Mình muốn lọc điểm lớn nhất của từng người ở sheet 1, lấy ra kết quả sang sheet 2. Nhờ các bạn giúp đỡ.
Nếu có thể thì giúp mình luôn code lọc điểm cao thứ 2 và thứ 3 ( Cái này có thể tùy chọn cần lấy kết quả thứ mấy)
 

File đính kèm

  • diem.xlsx
    13.1 KB · Đọc: 43
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
Hay nhỉ :thumbs:
 
Upvote 0
Haha nhìn mấy code này nhớ lại thời sinh viên quá đi, giờ mình làm chuyên lập trình php mấy cái này không nhớ nhiều không giúp anh em được
 
Upvote 0
Ở 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 ạ
Chỉ chấp nhận 1 số lẽ
Chỉnh các dòng lệnh
ReDim Arr(0 To 1000)
Diem = sArr(i, 10) * 10
For Diem = 1000 To 0 Step -1
Res(i, 5) = Diem / 10
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 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 Sub
 
Upvote 0
Chỉ chấp nhận 1 số lẽ
Chỉnh các dòng lệnh
ReDim Arr(0 To 1000)
Diem = sArr(i, 10) * 10
For Diem = 1000 To 0 Step -1
Res(i, 5) = Diem / 10
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 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 Sub
Vớ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.
 
Upvote 0
Vớ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.
Đúng thế mà.Nó chạy nhiều vòng lặp hơn thì chậm hơn là phải rồi.
 
Upvote 0
Vớ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.
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
 
Upvote 0
Tức là sắp xếp theo thứ tự rồi mới quét ấy ạ
Chạy code
Mã:
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
 
Upvote 0
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
Vậy với code này có cách nào tối ưu hơn ko ạ?
Bạn thử.
Mã:
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 Sub
 
Upvote 0
Chạy code
Mã:
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
Chuẩ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 ạ.
Bạn thử.
Mã:
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 Sub
Mình chạy code này nó ko hoạt động, đứng im luôn bạn ạ
 
Upvote 0
Chuẩ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 ạ
Bạn chỉnh chỗ này.
Const so As Integer = 5
Sửa thành số thứ tự bạn cần lấy.
 
Upvote 0
Web KT
Back
Top Bottom