Lọc danh sách sinh viên thi lại

[Yeuvoyeucon]

Kính gửi anh chị
Em có một File em lấy ở diễn đàn trước đây nay xem lại code thấy khó hiểu nhờ anh chị làm theo cách khác dễ hiểu hơn với ạ.
- Tại sheet Diem_TChi có danh sách cách sinh viên và kết quả thi các môn. Giờ muốn list ra các sinh viên và môn học mà sinh viên đó phải thi lại với điều kiện điểm tại các cột TKHP <4

 

[Yeuvoyeucon]

Đúng là cháu viết xong. Thấy dùng dic nó cứ thừa thừa cái gì ạ. Trót viết rồi. Nên khỏi sửa luôn. Hihi

Nhưng em thấy code của anh hay. Tuy không gọn như các anh/các bác nhưng em đọc hiểu hơn !he

 

[BuiQuangThuan]

Nhưng em thấy code của anh hay. Tuy không gọn như các anh/các bác nhưng em đọc hiểu hơn !he

Anh chị hiểu là được rồi.

 

[HUONGHCKT]

Cho em gop vui với. Có thiếu sót gì mong mọi người sửa giúp. Coi như học hỏi thêm

Sub ABC()
    Dim Arr(), Res(), Dic As Object, I&, J&, iKey, iRow&, K&, N&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Diem_TChi")
        iRow = .Range("B" & Rows.Count).End(3).Row
        If iRow < 10 Then Exit Sub
        Arr = .Range("A7:AM" & iRow).Value
    End With
    ReDim Res(1 To UBound(Arr, 1) * 6, 1 To 6)
    For I = 4 To UBound(Arr, 1)
        For J = 13 To 36 Step 4
            iKey = Arr(I, 2)
            If Arr(I, J) < 4 Then
                K = K + 1
                If Dic.exists(iKey) = False Then
                    N = N + 1
                    Dic.Add (iKey), iKey
                    Res(K, 1) = N: Res(K, 2) = iKey: Res(K, 3) = Arr(I, 3)
                    Res(K, 4) = Arr(I, 4): Res(K, 5) = Arr(I, 5)
                End If
                Res(K, 6) = Left(Split(Arr(1, J), "_")(1), Len(Split(Arr(1, J), "_")(1)) - 4)
            End If
        Next
    Next
    With Sheets("Thi_lai")
        .Range("I5").Resize(1000, 6).ClearContents
        If K Then .Range("I5").Resize(K, 6) = Res
    End With
End Sub

Dùng dic thì mình cũng đã nghĩ tới, xong cứ lay hoay các so sánh sArr(i,2) với sArr(i-1,2) theo hướng
For I = 4 To R
'If sArr(I, 2) <> sArr(I - 1, 2) Then
' M = M + 1
'End If
For J = 13 To CoLs Step 4
If sArr(I, J) < 4 Then
K = K + 1
M = M + 1
dArr(K, 1) = K
If M = 1 Then
For N = 2 To 5
dArr(K, N) = sArr(I, N)
Next N
End If
Mon = Split(sArr(1, J), "_")(1)
dArr(K + M, 6) = Left(Mon, Len(Mon) - 4)
End If
Next J
Next I
thử mãi mà không có kết quả như ý.===> thuật toán vẫn sai ở đâu đó.
Đọc Code anh VetMini mới thấy đúng là mình quá ngu, thêm một vòng for cho giá trị dArr(k,N)="" và gán giá trị của bước so sánh Mã SV vào k là ổn.

 

[BuiQuangThuan]

Dùng dic thì mình cũng đã nghĩ tới, xong cứ lay hoay các so sánh sArr(i,2) với sArr(i-1,2) theo hướng
For I = 4 To R
'If sArr(I, 2) <> sArr(I - 1, 2) Then
' M = M + 1
'End If
For J = 13 To CoLs Step 4
If sArr(I, J) < 4 Then
K = K + 1
M = M + 1
dArr(K, 1) = K
If M = 1 Then
For N = 2 To 5
dArr(K, N) = sArr(I, N)
Next N
End If
Mon = Split(sArr(1, J), "_")(1)
dArr(K + M, 6) = Left(Mon, Len(Mon) - 4)
End If
Next J
Next I
thử mãi mà không có kết quả như ý.===> thuật toán vẫn sai ở đâu đó.
Đọc Code anh VetMini mới thấy đúng là mình quá ngu, thêm một vòng for cho giá trị dArr(k,N)="" và gán giá trị của bước so sánh Mã SV vào k là ổn.

Hihi. Đọc code của chú ấy. Em cũng thấy tự dưng dùng dic. Kiểu bị thừa. Tại tắt máy rồi. Em không test được. Nhưng gợi ý của chú ấy. Đúng là hay đấy.

 

[VetMini]

Code ở trên là tôi minh hoạ cách so sánh nhóm dữ liệu: chuyển từ nhóm này sang nhóm kế tiếp. Mỗi nhóm đầu ra đầu vào đều gồm nhiều dòng.

Thực ra bài này có thể code giản dị hơn một chút bởi vì mỗi nhóm đầu vào là 1 dòng.

 

[BuiQuangThuan]

Code ở trên là tôi minh hoạ cách so sánh nhóm dữ liệu: chuyển từ nhóm này sang nhóm kế tiếp. Mỗi nhóm đầu ra đầu vào đều gồm nhiều dòng.

Thực ra bài này có thể code giản dị hơn một chút bởi vì mỗi nhóm đầu vào là 1 dòng.

Lúc cháu viết xong. Cháu chợt nghĩ. Mà sinh viên không ai giống ai. Dùng dic chỉ để lấy số thứ tự. Thì lãng phí quá. Thấy gợi ý của chú. Chậc lưỡi. Ừ nhỉ. Sao mình dốt quá vậy

 

[concogia]

Có lẽ tôi nhầm, Xin lỗi anh SA_DQ nhé.
Nhưng chắc chắc là của 1 anh nào đó rất có uy tín trên diễn đàn này viết.
Tôi muốn sửa lại code theo ý riêng là một Sinh viên phải thi lại nhiều môn thì trong Bảng Danh sách SV thi lại môn chỉ hiển thị tên một lần kiểu: (như hình dưới) mà làm mãi không được. Anh em nào có ghé qua, xin cho hướng giải quyết.
Trân trọng

số TT	Mã SV	Họ và tên SV	ngày tháng năm sinh	Môn phải thi lại
1​	DD001	Nguyễn Văn A	1/1/999	Kinh tế
				Triết học
				Hóa học
				Giải phẫu
2​	DD045	Hoàng thị N	2/3/1999​	Triết học
3​	DD0056	Cao Anh H	4/5/1998​	Kinh tế
				Hóa học
				Ngoại ngữ

Có lẽ tôi nhầm, Xin lỗi anh SA_DQ nhé.
Nhưng chắc chắc là của 1 anh nào đó rất có uy tín trên diễn đàn này viết.
Tôi muốn sửa lại code theo ý riêng là một Sinh viên phải thi lại nhiều môn thì trong Bảng Danh sách SV thi lại môn chỉ hiển thị tên một lần kiểu: (như hình dưới) mà làm mãi không được. Anh em nào có ghé qua, xin cho hướng giải quyết.
Trân trọng

số TT	Mã SV	Họ và tên SV	ngày tháng năm sinh	Môn phải thi lại
1​	DD001	Nguyễn Văn A	1/1/999	Kinh tế
				Triết học
				Hóa học
				Giải phẫu
2​	DD045	Hoàng thị N	2/3/1999​	Triết học
3​	DD0056	Cao Anh H	4/5/1998​	Kinh tế
				Hóa học
				Ngoại ngữ

Mỗi Mã sinh viên nằm 1 dòng, những dòng thoả điều kiện thi lại nằm ở vòng lặp (J), khi gặp Cell thoả nó chạy:
K = K + 1
dArr(K, 1) = K
For N = 2 To 5
dArr(K, N) = sArr(I, N)
Next N
Mon = Split(sArr(1, J), "_")(1)
dArr(K, 6) = Left(Mon, Len(Mon) - 4)
Muốn có kết quả như trên thì khi gặp điều kiện thoả lần 2 trở lên chỉ chạy khúc cuối gán giá trị khúc này:
Mon = Split(sArr(1, J), "_")(1)
dArr(K, 6) = Left(Mon, Len(Mon) - 4)
Dĩ nhiên K phải là 1 biến khác

 

[HUONGHCKT]

Ở GPE này người ta dùng Dictionary dễ quá cho nên quên mất kỹ thuật căn bản của so sánh từng dòng.
Dùng mã SV để dò. Nếu mã giống trước đó thì chép "", giản dị vậy thôi.

Const COTMASV = 2
Dim maSV As String, nuSTT As Long
maSV = "???"
For I = 4 To R
For J = 13 To CoLs Step 4
If sArr(I, J) < 4 Then
K = K + 1
' dArr(K, 1) = K
If sArr(I, COTMASV) <> maSV Then
nuSTT = nuSTT + 1
dArr(K, 1) = nuSTT
For N = 2 To 5
dArr(K, N) = ""
Next N
maSV = sArr(i, COTMASV)
Else
For N = 2 To 5
dArr(K, N) = sArr(I, N)
Next N
End If
Mon = Split(sArr(1, J), "_")(1)
dArr(K, 6) = Left(Mon, Len(Mon) - 4)
End If
Next J
Next I

Cảm ơn anh. Không hiểu hay là máy tôi bị sao chứ copy đoạn code anh sửa dán vào máy tôi thì chạy cho ra kết quả chưa được như ý. mày mò mãi (từ lúc anh đăng bài và đến sau khi anh chỉnh sửa) và thấy chỗ này (bôi đen) phải hoán vị cho nhau khi chay code mới cho ra kết quả đúng.
If sArr(I, COTMASV) <> maSV Then
nuSTT = nuSTT + 1
dArr(K, 1) = nuSTT
For N = 2 To 5
dArr(K, N) = ""
Next N
maSV = sArr(I, COTMASV)
Else
For N = 2 To 5
dArr(K, N) = sArr(I, N)
Next N
End If

 

[VetMini]

Cảm ơn anh. Không hiểu hay là máy tôi bị sao chứ copy đoạn code anh sửa dán vào máy tôi thì chạy cho ra kết quả chưa được như ý. mày mò mãi (từ lúc anh đăng bài và đến sau khi anh chỉnh sửa) và thấy chỗ này (bôi đen) phải hoán vị cho nhau khi chay code mới cho ra kết quả đúng.

Xin lỗi, do copy paste mọt hồi lộn tùng phèng hết.

 

[HieuCD]

Góp vui

Sub ABC()
  Dim sArr(), Res(), eR&, eC&, sRow&, sCol&, i&, k&, stt&, j&, c&, ma$
  With Sheets("Diem_TChi")
    eR = .Range("A1000").End(xlUp).Row 'Dong cuoi
    eC = .Range("AAA7").End(xlToLeft).Column 'Cot cuoi
    sArr = .Range("A7", .Cells(eR, eC)).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 6, 1 To 6)
  For i = 4 To sRow
    For j = 13 To sCol Step 4
      If sArr(i, j) < 4 Then
        k = k + 1
        If ma <> sArr(i, 2) Then
          ma = sArr(i, 2)
          stt = stt + 1
          Res(k, 1) = stt
          For c = 2 To 5
            Res(k, c) = sArr(i, c)
          Next c
        End If
        Res(k, 6) = Split(Split(sArr(1, j), "_")(1), " (")(0) 'Mon thi lai
      End If
    Next j
  Next i
  With Sheets("Thi_lai")
    eR = .Range("A10000").End(xlUp).Row 'Dong cuoi
    If eR > 4 Then .Range("A5:F" & eR).ClearContents
    If k Then
      .Range("B5").Resize(k).NumberFormat = "@"
      .Range("A5").Resize(k, 6) = Res
    End If
  End With
End Sub

 

[SA_DQ]

. . . . . . EM chưa nhìn thấy cách viết kiểu thế bao giờ ? nó là cách viết theo lý thuyết nào anh nhỉ ? nhất là cái chỗ (1)

Bạn thử chạy macro này để suy ra con số 1 đó 1 cách tương tự

Sub XemChiSoLaNhuTheNao()
 Dim Rng As Range, J As Integer

 Set Rng = Range([B2], [C4])
 For J = 1 To Rng.Cells.Count
    MsgBox Rng(J).Address
 Next J
End Sub

Sub XemChiSoLaNhuTheNao()
 Dim Arr, W As Integer
 
 Arr = Split("Công Tàng Tôn Ái Nguyêt Minh", " ")
 For W = 0 To UBound(Arr) - 1
    MsgBox Arr(W)
 Next W
End Sub

 

[Yeuvoyeucon]

Bạn thử chạy macro này để suy ra con số 1 đó 1 cách tương tự

Sub XemChiSoLaNhuTheNao()
 Dim Rng As Range, J As Integer

 Set Rng = Range([B2], [C4])
 For J = 1 To Rng.Cells.Count
    MsgBox Rng(J).Address
 Next J
End Sub

Sub XemChiSoLaNhuTheNao()
 Dim Arr, W As Integer
 
 Arr = Split("Công Tàng Tôn Ái Nguyêt Minh", " ")
 For W = 0 To UBound(Arr) - 1
    MsgBox Arr(W)
 Next W
End Sub

Em cảm ơn anh ạ. Để em chạy thử để hiểu hàm VBA này ạ!

 

[Hai Lúa Miền Tây]

Kính gửi anh chị
Em có một File em lấy ở diễn đàn trước đây nay xem lại code thấy khó hiểu nhờ anh chị làm theo cách khác dễ hiểu hơn với ạ.
- Tại sheet Diem_TChi có danh sách cách sinh viên và kết quả thi các môn. Giờ muốn list ra các sinh viên và môn học mà sinh viên đó phải thi lại với điều kiện điểm tại các cột TKHP <4

Bạn thử với code sau nhé:

Sub Gop_HLMT()
    Dim strSql As String
    With Sheet1
        strSql = "Select F2,F3,F4,F5,'" & .Range("M7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F13<4 or F13 is null) " & _
            " Union All Select F2,F3,F4,F5,'" & .Range("Q7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F17<4 or F17 is null) " & _
            " Union All Select F2,F3,F4,F5,'" & .Range("U7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F21<4 or F21 is null) " & _
            " Union All Select F2,F3,F4,F5,'" & .Range("Y7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F25<4 or F25 is null) " & _
            " Union All Select F2,F3,F4,F5,'" & .Range("AC7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F29<4 or F29 is null) " & _
            " Union All Select F2,F3,F4,F5,'" & .Range("AG7") & "' From [Diem_TChi$A10:AM] where F2 Is not Null and (F33<4 or F33 is null) "
    End With
    With CreateObject("ADODB.Recordset")
        .Open "Select * from ( " & strSql & ") Order By F4,F3,F2", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO;IMEX=1"""
        Sheet4.Range("H5").CopyFromRecordset .DataSource
    End With
End Sub