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

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
329
Được thích
41
Điểm
685
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

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,410
Được thích
2,276
Điểm
360
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)
Bạn thử nhé.
Mã:
Sub khongxembongda()
    Dim arr, kq, i As Long, a As Long, lr As Long, dic As Object, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B2:E" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 5)
    End With
        For i = 1 To UBound(arr)
            dk = UCase(arr(i, 1))
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = a
               kq(a, 2) = arr(i, 1)
               kq(a, 3) = arr(i, 2)
               kq(a, 4) = arr(i, 3)
               kq(a, 5) = arr(i, 4)
            Else
               b = dic.Item(dk)
               If kq(b, 4) < arr(i, 3) Then
                  kq(b, 3) = arr(i, 2)
                  kq(b, 4) = arr(i, 3)
                  kq(b, 5) = arr(i, 4)
               End If
           End If
      Next i
   With Sheets("sheet2")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:E" & lr).ClearContents
        If a Then .Range("A2:E2").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
329
Được thích
41
Điểm
685
Bạn thử nhé.
Mã:
Sub khongxembongda()
    Dim arr, kq, i As Long, a As Long, lr As Long, dic As Object, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B2:E" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 5)
    End With
        For i = 1 To UBound(arr)
            dk = UCase(arr(i, 1))
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = a
               kq(a, 2) = arr(i, 1)
               kq(a, 3) = arr(i, 2)
               kq(a, 4) = arr(i, 3)
               kq(a, 5) = arr(i, 4)
            Else
               b = dic.Item(dk)
               If kq(b, 4) < arr(i, 3) Then
                  kq(b, 3) = arr(i, 2)
                  kq(b, 4) = arr(i, 3)
                  kq(b, 5) = arr(i, 4)
               End If
           End If
      Next i
   With Sheets("sheet2")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:E" & lr).ClearContents
        If a Then .Range("A2:E2").Resize(a).Value = kq
  End With
End Sub
Đúng rồi bạn ạ. Nhưng mình quên mất 1 cái, đó là như trong file mẫu thì nếu 1 người mà có nhiều kỳ thi có điểm cao nhất bằng nhau thì liệt kê tất cả luôn ạ.
Ngoài ra có thêm cái điểm cao thứ 2 và thứ 3 bạn giúp mình luôn nhé.
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,410
Được thích
2,276
Điểm
360
Đúng rồi bạn ạ. Nhưng mình quên mất 1 cái, đó là như trong file mẫu thì nếu 1 người mà có nhiều kỳ thi có điểm cao nhất bằng nhau thì liệt kê tất cả luôn ạ.
Ngoài ra có thêm cái điểm cao thứ 2 và thứ 3 bạn giúp mình luôn nhé.
File điểm của bạn có thể sắp xếp theo thứ tự điểm từ trên xuống dưới được không.Hay bắt buộc phải để như vậy.
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
329
Được thích
41
Điểm
685
File điểm của bạn có thể sắp xếp theo thứ tự điểm từ trên xuống dưới được không.Hay bắt buộc phải để như vậy.
Bắt buộc phải để vậy ạ
Bài đã được tự động gộp:

kq(a, 1) = a
kq(a, 2) = arr(i, 1)
kq(a, 3) = arr(i, 2)
kq(a, 4) = arr(i, 3)
kq(a, 5) = arr(i, 4)
Else
b = dic.Item(dk)
If kq(b, 4) < arr(i, 3) Then
kq(b, 3) = arr(i, 2)
kq(b, 4) = arr(i, 3)
kq(b, 5) = arr(i, 4)
End If
Cái đoạn này có thể viết gọn hơn lại được ko bạn nhỉ, vì lỡ dữ liệu có hàng chục cột chẳng hạn viết thế này sẽ dài ngoằng. Cái này mình muốn hiểu thêm nên hỏi thôi.
 
Lần chỉnh sửa cuối:

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,410
Được thích
2,276
Điểm
360
Bắt buộc phải để vậy ạ
Bài đã được tự động gộp:


Cái đoạn này có thể viết gọn hơn lại được ko bạn nhỉ, vì lỡ dữ liệu có hàng chục cột chẳng hạn viết thế này sẽ dài ngoằng. Cái này mình muốn hiểu thêm nên hỏi thôi.
Dược Bạn thay thế bằng vòng lặp FOR Next.Nếu dữ liệu như vậy viết code dài lắm.Mà mình dạo này bận nên không viết được.Bạn đợi bạn khác giúp nhé.:D.
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
329
Được thích
41
Điểm
685
Dược Bạn thay thế bằng vòng lặp FOR Next.Nếu dữ liệu như vậy viết code dài lắm.Mà mình dạo này bận nên không viết được.Bạn đợi bạn khác giúp nhé.:D.
Vâng, cảm ơn bạn đã giúp đỡ.
Nhờ các bạn khác giúp mình chút ạ.
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,410
Được thích
2,276
Điểm
360
Bạn làm theo thuật toán là sắp xếp theo thứ tự từ trên xuống dưới rồi duyệt dữ liệu từ trên xuống dưới.lấy các giá trị bằng nhau đầu tiên là được đáp án thứ nhất.lấy giá trị thứ 2 là được đáp án thứ 2.hihi
 

CHAOQUAY

Thành viên tích cực
Tham gia ngày
24 Tháng tám 2018
Bài viết
847
Được thích
818
Điểm
360
Đúng rồi bạn ạ. Nhưng mình quên mất 1 cái, đó là như trong file mẫu thì nếu 1 người mà có nhiều kỳ thi có điểm cao nhất bằng nhau thì liệt kê tất cả luôn ạ.
Ngoài ra có thêm cái điểm cao thứ 2 và thứ 3 bạn giúp mình luôn nhé.
Điểm cao thứ 1 hoặc 2 hoặc 3... : Thay đổi giá trị của k
Mã:
Sub locdiem()
Dim DL
Dim Diem
Dim Mang
Dim Kq
Dim rws
Dim i, j, k, x, z, t
DL = Sheet1.Range("A1").CurrentRegion
rws = UBound(DL)
ReDim Diem(100)
With CreateObject("Scripting.Dictionary")
    For i = 2 To rws
        If .Exists(DL(i, 2)) = False Then
            Mang = Diem
            Mang(DL(i, 4)) = DL(i, 3)
            .Item(DL(i, 2)) = Mang
        Else
            Mang = .Item(DL(i, 2))
            Mang(DL(i, 4)) = Mang(DL(i, 4)) & IIf(Mang(DL(i, 4)), " ", "") & DL(i, 3)
            .Item(DL(i, 2)) = Mang
        End If
    Next i
    ReDim Kq(1 To rws, 1 To 5)
    k = 1
    x = 0
    For i = 0 To .Count - 1
        Mang = .Items()(i)
        z = 0
        For j = 100 To 0 Step -1
            If Mang(j) <> "" Then z = z + 1
            If z = k Then
                t = Mang(j)
                Exit For
            End If
        Next j
        If InStr(t, " ") = 0 Then
            x = x + 1
            Kq(x, 1) = x
            Kq(x, 2) = .Keys()(i)
            Kq(x, 3) = t
            Kq(x, 4) = j
        Else
            For Each z In Split(t)
                x = x + 1
                Kq(x, 1) = x
                Kq(x, 2) = .Keys()(i)
                Kq(x, 3) = z
                Kq(x, 4) = j
            Next z
        End If
    Next i
End With
Sheet2.Range("A2").Resize(x, UBound(Kq, 2)) = Kq
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
329
Được thích
41
Điểm
685
Điểm cao thứ 1 hoặc 2 hoặc 3... : Thay đổi giá trị của k
Mã:
Sub locdiem()
Dim DL
Dim Diem
Dim Mang
Dim Kq
Dim rws
Dim i, j, k, x, z, t
DL = Sheet1.Range("A1").CurrentRegion
rws = UBound(DL)
ReDim Diem(100)
With CreateObject("Scripting.Dictionary")
    For i = 2 To rws
        If .Exists(DL(i, 2)) = False Then
            Mang = Diem
            Mang(DL(i, 4)) = DL(i, 3)
            .Item(DL(i, 2)) = Mang
        Else
            Mang = .Item(DL(i, 2))
            Mang(DL(i, 4)) = Mang(DL(i, 4)) & IIf(Mang(DL(i, 4)), " ", "") & DL(i, 3)
            .Item(DL(i, 2)) = Mang
        End If
    Next i
    ReDim Kq(1 To rws, 1 To 5)
    k = 1
    x = 0
    For i = 0 To .Count - 1
        Mang = .Items()(i)
        z = 0
        For j = 100 To 0 Step -1
            If Mang(j) <> "" Then z = z + 1
            If z = k Then
                t = Mang(j)
                Exit For
            End If
        Next j
        If InStr(t, " ") = 0 Then
            x = x + 1
            Kq(x, 1) = x
            Kq(x, 2) = .Keys()(i)
            Kq(x, 3) = t
            Kq(x, 4) = j
        Else
            For Each z In Split(t)
                x = x + 1
                Kq(x, 1) = x
                Kq(x, 2) = .Keys()(i)
                Kq(x, 3) = z
                Kq(x, 4) = j
            Next z
        End If
    Next i
End With
Sheet2.Range("A2").Resize(x, UBound(Kq, 2)) = Kq
End Sub
Cảm ơn bạn, đúng như ý mình rồi đó ạ. Nhưng code của bạn "snow25" mình đọc có thể hiểu được, chứ code của bạn mình ngồi đến giờ này ngâm vẫn chưa hiểu hết. Bạn có thể chú thích code giúp mình không? Mình cũng đang học nên rất muốn hiểu được, sau đỡ hỏi.
Bài đã được tự động gộp:

Bạn làm theo thuật toán là sắp xếp theo thứ tự từ trên xuống dưới rồi duyệt dữ liệu từ trên xuống dưới.lấy các giá trị bằng nhau đầu tiên là được đáp án thứ nhất.lấy giá trị thứ 2 là được đáp án thứ 2.hihi
Với code của bạn thì để lấy giá trị bằng nhau thứ 2 mình phải sửa thế nào ạ??
 

CHAOQUAY

Thành viên tích cực
Tham gia ngày
24 Tháng tám 2018
Bài viết
847
Được thích
818
Điểm
360
Cảm ơn bạn, đúng như ý mình rồi đó ạ. Nhưng code của bạn "snow25" mình đọc có thể hiểu được, chứ code của bạn mình ngồi đến giờ này ngâm vẫn chưa hiểu hết. Bạn có thể chú thích code giúp mình không? Mình cũng đang học nên rất muốn hiểu được, sau đỡ hỏi.
Bạn xem chú thích bên dưới
Mã:
Sub locdiem()
Dim DL
Dim Diem
Dim Mang
Dim Kq
Dim rws
Dim i, j, k, x, z, t
DL = Sheet1.Range("A1").CurrentRegion
rws = UBound(DL)
ReDim Diem(100)
With CreateObject("Scripting.Dictionary")
    'Nap danh sach vao Dic.
    'Key=Ten; Item=Mang 101 phan tu ( 0-100 )
    'Lay diem so lam vitri trong Mang, dien lan thi vao vi tri do
    For i = 2 To rws
        If .Exists(DL(i, 2)) = False Then
            Mang = Diem '<--Mang 101 phan tu ( 0-100 )
            Mang(DL(i, 4)) = DL(i, 3) '<--'Lay diem so lam vitri trong Mang, dien lan thi vao vitri do
            .Item(DL(i, 2)) = Mang
        Else
            Mang = .Item(DL(i, 2))
            Mang(DL(i, 4)) = Mang(DL(i, 4)) & IIf(Mang(DL(i, 4)), " ", "") & DL(i, 3)
            .Item(DL(i, 2)) = Mang
        End If
    Next i
    'KT Nap danh sach vao Dic.
    
    'Xuat ket qua
    ReDim Kq(1 To rws, 1 To 5)
    k = 1
    x = 0
    For i = 0 To .Count - 1
        Mang = .Items()(i) 'Keys()(i)=Ten; .Items()(i)=Danh sach lan thi tuong ung
        
        'Dem nguoc tu 100-0, tim diem thi cao thu k, lay ra so lan thi tai diem do
        z = 0
        For j = 100 To 0 Step -1
            If Mang(j) <> "" Then z = z + 1
            If z = k Then
                t = Mang(j)
                Exit For
            End If
        Next j
        'KT Dem nguoc tu 100-0, tim diem thi cao thu k, lay ra so lan thi tai diem do
        
        'Kiem tra xem thi 1 hay nhieu lan, dien diem so, lan thi vao Kq
        If InStr(t, " ") = 0 Then '<--Thi 1 lan
            x = x + 1
            Kq(x, 1) = x
            Kq(x, 2) = .Keys()(i)
            Kq(x, 3) = t
            Kq(x, 4) = j
        Else
            For Each z In Split(t) '<--Thi >1 lan
                x = x + 1
                Kq(x, 1) = x
                Kq(x, 2) = .Keys()(i)
                Kq(x, 3) = z
                Kq(x, 4) = j
            Next z
        End If
        'KT Kiem tra xem thi 1 hay nhieu lan, dien diem so, lan thi vao Kq
    Next i
    'KT Xuat ket qua
End With
Sheet2.Range("A2").Resize(x, UBound(Kq, 2)) = Kq
End Sub
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,187
Được thích
11,496
Điểm
1,560
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)
Thử code
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&
 
  Sheet2.Range("A2:D500").ClearContents
  iRnk = Application.InputBox(prompt:="Nhap Diem Cao thu:", Type:=1)
  If iRnk = 0 Then Exit Sub
  With Sheet1
    sArr = .Range("B2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  ReDim Arr(0 To 100)
  ReDim Res(1 To sRow, 1 To 4)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1): Diem = sArr(i, 3)
      If .Exists(SV) = False Then
        k = k + 1:              Res(k, 1) = k
        Res(k, 2) = SV:        .Add SV, Arr
      End If
      tmp = .Item(SV)
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2)
      .Item(SV) = tmp
    Next i
    If k Then
      For i = 1 To k
        tmp = .Item(Res(i, 2))
        q = 0
        For Diem = 100 To 0 Step -1
          If tmp(Diem) <> Empty Then q = q + 1
          If q = iRnk Then
            Res(i, 3) = Mid(tmp(Diem), 3, 50)
            Res(i, 4) = Diem
            Exit For
          End If
        Next Diem
      Next i
      Sheet2.Range("A2").Resize(k, 4) = Res
    End If
  End With
End Sub
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,308
Được thích
541
Điểm
860
Thử code
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&

  Sheet2.Range("A2:D500").ClearContents
  iRnk = Application.InputBox(prompt:="Nhap Diem Cao thu:", Type:=1)
  If iRnk = 0 Then Exit Sub
  With Sheet1
    sArr = .Range("B2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  ReDim Arr(0 To 100)
  ReDim Res(1 To sRow, 1 To 4)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1): Diem = sArr(i, 3)
      If .Exists(SV) = False Then
        k = k + 1:              Res(k, 1) = k
        Res(k, 2) = SV:        .Add SV, Arr
      End If
      tmp = .Item(SV)
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2)
      .Item(SV) = tmp
    Next i
    If k Then
      For i = 1 To k
        tmp = .Item(Res(i, 2))
        q = 0
        For Diem = 100 To 0 Step -1
          If tmp(Diem) <> Empty Then q = q + 1
          If q = iRnk Then
            Res(i, 3) = Mid(tmp(Diem), 3, 50)
            Res(i, 4) = Diem
            Exit For
          End If
        Next Diem
      Next i
      Sheet2.Range("A2").Resize(k, 4) = Res
    End If
  End With
End Sub
Thầy xử lý Array ra tay rồi
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
329
Được thích
41
Điểm
685
Thử code
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&

  Sheet2.Range("A2:D500").ClearContents
  iRnk = Application.InputBox(prompt:="Nhap Diem Cao thu:", Type:=1)
  If iRnk = 0 Then Exit Sub
  With Sheet1
    sArr = .Range("B2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  ReDim Arr(0 To 100)
  ReDim Res(1 To sRow, 1 To 4)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1): Diem = sArr(i, 3)
      If .Exists(SV) = False Then
        k = k + 1:              Res(k, 1) = k
        Res(k, 2) = SV:        .Add SV, Arr
      End If
      tmp = .Item(SV)
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2)
      .Item(SV) = tmp
    Next i
    If k Then
      For i = 1 To k
        tmp = .Item(Res(i, 2))
        q = 0
        For Diem = 100 To 0 Step -1
          If tmp(Diem) <> Empty Then q = q + 1
          If q = iRnk Then
            Res(i, 3) = Mid(tmp(Diem), 3, 50)
            Res(i, 4) = Diem
            Exit For
          End If
        Next Diem
      Next i
      Sheet2.Range("A2").Resize(k, 4) = Res
    End If
  End With
End Sub
Cảm ơn bác ạ, code rất hay ạ. Bác cho em xin cái giải thích code được không ạ.
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,187
Được thích
11,496
Điểm
1,560
Cảm ơn bác ạ, code rất hay ạ. Bác cho em xin cái giải thích code được không ạ.
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&
 
  Sheet2.Range("A2:D500").ClearContents 'Xoa ket qua
  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("B2", .Range("D" & 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 4) 'Mang Ket Qua
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1) 'Ten Sinh Vien
      Diem = sArr(i, 3) 'Diem so cua sinh vien
      If .Exists(SV) = False Then 'Loc sinh vien duy nhat
        k = k + 1
        Res(k, 1) = k 'So thu tu sinh vien
        Res(k, 2) = SV 'Ten Sinh Vien
        .Add SV, Arr 'Add sinh vien vao Dic de loai trung, voi Item la mang Diem
      End If
      tmp = .Item(SV) 'Mang "Lan Thi"
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2) 'Gan "Lan Thi" vào dong "Diem"
      .Item(SV) = tmp 'Gan tmp vào Item cua Dic
    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
            Res(i, 3) = Mid(tmp(Diem), 3, 50) 'Lan thi, loai bo dau ", " o dau ket qua
            Res(i, 4) = 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("A2").Resize(k, 4) = Res 'Gan ket qua
    End If
  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
329
Được thích
41
Điểm
685
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&

  Sheet2.Range("A2:D500").ClearContents 'Xoa ket qua
  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("B2", .Range("D" & 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 4) 'Mang Ket Qua
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1) 'Ten Sinh Vien
      Diem = sArr(i, 3) 'Diem so cua sinh vien
      If .Exists(SV) = False Then 'Loc sinh vien duy nhat
        k = k + 1
        Res(k, 1) = k 'So thu tu sinh vien
        Res(k, 2) = SV 'Ten Sinh Vien
        .Add SV, Arr 'Add sinh vien vao Dic de loai trung, voi Item la mang Diem
      End If
      tmp = .Item(SV) 'Mang "Lan Thi"
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2) 'Gan "Lan Thi" vào dong "Diem"
      .Item(SV) = tmp 'Gan tmp vào Item cua Dic
    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
            Res(i, 3) = Mid(tmp(Diem), 3, 50) 'Lan thi, loai bo dau ", " o dau ket qua
            Res(i, 4) = 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("A2").Resize(k, 4) = Res 'Gan ket qua
    End If
  End With
End Sub
Em cảm ơn ạ
 

pinklove

Thành viên thường trực
Tham gia ngày
21 Tháng một 2008
Bài viết
329
Được thích
41
Điểm
685
Mã:
Sub LargeNumeFilter()
  Dim sArr(), Res(), Arr(), tmp, SV$, Diem&
  Dim sRow&, iRnk&, i&, j&, k&, q&

  Sheet2.Range("A2:D500").ClearContents 'Xoa ket qua
  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("B2", .Range("D" & 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 4) 'Mang Ket Qua
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sRow
      SV = sArr(i, 1) 'Ten Sinh Vien
      Diem = sArr(i, 3) 'Diem so cua sinh vien
      If .Exists(SV) = False Then 'Loc sinh vien duy nhat
        k = k + 1
        Res(k, 1) = k 'So thu tu sinh vien
        Res(k, 2) = SV 'Ten Sinh Vien
        .Add SV, Arr 'Add sinh vien vao Dic de loai trung, voi Item la mang Diem
      End If
      tmp = .Item(SV) 'Mang "Lan Thi"
      tmp(Diem) = tmp(Diem) & ", " & sArr(i, 2) 'Gan "Lan Thi" vào dong "Diem"
      .Item(SV) = tmp 'Gan tmp vào Item cua Dic
    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
            Res(i, 3) = Mid(tmp(Diem), 3, 50) 'Lan thi, loai bo dau ", " o dau ket qua
            Res(i, 4) = 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("A2").Resize(k, 4) = Res 'Gan ket qua
    End If
  End With
End Sub
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 ạ.
 

File đính kèm

Top Bottom