Dùng VBA, lọc danh sách sinh viên theo thứ tự nguyện vọng

[Phuocam]

Bài này Record Macro, sửa lại một chút để lấy dòng cuối động:

Sub Macro1()
Dim lastRow As Long
With Sheets("Sheet1")
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:F" & lastRow).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=.Range("J1:J2"), CopyToRange:=Sheets("LOC").Range("B9:G9") , Unique:=False
End With
End Sub

Nếu dùng mảng +Dic, chỉ cần 2 vòng For.

.

 

[vodinhnam]

Câu hỏi của bạn í trong bài này rất rõ:
1) Tìm trong cột 6 ( mã ngành ) em nào giống với điều kiện lọc thì giữ em đó lại
2) Tìm xem cái em vừa giữ lại có đăng ký hơn 1 nguyện vọng không, nếu có thì liệt kê ra, nếu không thì thôi
Cái này là ý của mình thôi nhé
Thân

Bác hiểu yêu cầu của bài toán vậy là chuẩn rồi í ạ.
Nhưng điều kiện lọc ở đây không phải chỉ có 1 như trong ví dụ mà là 1 list.
Như vậy vòng lặp sẽ lấy lần lượt lấy từng tiêu chí trong list so sánh để lấy các row phù hợp trong Sheet 1 mà copy sang Sheet LOC.

Bài đã được tự động gộp: 6/7/21

Mình nghĩ đơn giản thế này, với dữ liệu lớn ( khoảng 80.000) mà chỉ kiếm 1 học sinh thì ....hơi vô lý, nhưng thôi kệ
Thân

đó là ví dụ thôi bác, hihi, bài toán thật nó sẽ khác tí

Bài đã được tự động gộp: 6/7/21

80 ngàn dòng nguyện vọng sinh viên đem đưa cho một người chỉ biết xin code.
Tội nghiệp sinh viên trường này thật.

hihi, cám ơn bác đã comment, nên tập trung vào vấn đề cần giải quyết hơn là nhận xét về đối tượng, bác nhé.
Chúc bác vui, khỏe!

 

[Ba Tê]

hihi, cám ơn bác đã comment, nên tập trung vào vấn đề cần giải quyết hơn là nhận xét về đối tượng, bác nhé.
Chúc bác vui, khỏe!

Theo tôi thì "nhận xét về đối tượng" mới nghĩ ra cách giải quyết vấn đề cho phù hợp với "đối tượng".
Giải quyết không phù hợp sẽ rất "lôi thôi", sẽ có "nhưng mà", sẽ có "Nhưng điều kiện lọc ở đây không phải chỉ có 1 như trong ví dụ mà là 1 list.", " hihi, bài toán thật nó sẽ khác tí", rồi ... sẽ chẳng đâu vào đâu khi đã giúp.

 

[VetMini]

Theo tôi thì "nhận xét về đối tượng" mới nghĩ ra cách giải quyết vấn đề cho phù hợp với "đối tượng".
...

Ở GPE này, người ta nhỏng nhẻo quen rồi.
Họ không muốn bạn "nghĩ ra giải pháp phù hợp". Họ đã có giải pháp rồi và chỉ "tập trung vào" việc đòi hỏi code cho giải pháp ấy thôi.

Cũng như dứa con nít vòi kẹo. Nếu nhắm thấy khóc nhè sẽ được kẹo thì không bao giờ nó nghe những câu "kẹo ăn nhiều hư răng..."

Trên nguyên tắc, những người nắm vững được công việc của mình đáng lẽ phải biết tự viết code giải quyết vấn đề cần thực hiện, và chỉ hỏi một đôi chỗ khó khăn thôi.
Đã nhờ từ a đến z mà còn lên mặt dạy "nên tập trung vào..."

 

[HieuCD]

Chào toàn thể anh, chị em GPE,

Mình có 1 file dữ liệu do sinh viên đăng ký các nguyện vọng (NV), mỗi SV có thể đăng ký nhiều NV (sheet 1).
Giờ mình muốn tìm trong sheet 1 các sinh viên nào đăng ký nhiều hơn 01 NV và có NV bất kỳ (giả sử NV thứ i) có mã ngành thỏa mãn điều kiện LỌC được nêu ở sheet LOC. Sau đó copy toàn bộ các thông tin từ NV thứ i đến NV cuối cùng sang sheet LOC.
Rất mong bà con GPE giúp đỡ.
Đang cao điểm dịch, chúc bà con an toàn, sức khỏe.
Trân trọng cám ơn./.

Chạy code

Sub ABC()
  Dim sArr(), aNganh(), Res$(), dic As Object
  Dim sRow&, i&, r&, k&, j& , nganh$, sv$, nv&
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("LOC")
    aNganh = .Range("K5:L" & .Range("K" & Rows.Count).End(xlUp).Row).Value
  End With
  For i = 1 To UBound(aNganh)
    dic.Item(aNganh(i, 1)) = ""
  Next i
  With Sheets("Sheet1")
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 6)
  For i = 1 To sRow
    If dic.exists(sArr(i, 6)) Then
      sv = sArr(i, 2)
      If sv = sArr(i + 1, 2) Then
        For r = i To sRow
          If sv <> sArr(r, 2) Then i = r - 1: Exit For
          k = k + 1
          For j = 1 To 6
            Res(k, j) = sArr(r, j)
          Next j
        Next r
      End If
    End If
  Next i
  With Sheets("LOC")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 9 Then .Range("B10:G" & i).ClearContents
    If k Then .Range("B10").Resize(k, 6) = Res
  End With
End Sub

 

[vodinhnam]

Chạy code

Sub ABC()
  Dim sArr(), aNganh(), Res$(), dic As Object
  Dim sRow&, i&, r&, k&, j& , nganh$, sv$, nv&
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("LOC")
    aNganh = .Range("K5:L" & .Range("K" & Rows.Count).End(xlUp).Row).Value
  End With
  For i = 1 To UBound(aNganh)
    dic.Item(aNganh(i, 1)) = ""
  Next i
  With Sheets("Sheet1")
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 6)
  For i = 1 To sRow
    If dic.exists(sArr(i, 6)) Then
      sv = sArr(i, 2)
      If sv = sArr(i + 1, 2) Then
        For r = i To sRow
          If sv <> sArr(r, 2) Then i = r - 1: Exit For
          k = k + 1
          For j = 1 To 6
            Res(k, j) = sArr(r, j)
          Next j
        Next r
      End If
    End If
  Next i
  With Sheets("LOC")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 9 Then .Range("B10:G" & i).ClearContents
    If k Then .Range("B10").Resize(k, 6) = Res
  End With
End Sub

Em cám ơn bác nhé!
Cheers!