Nhờ lọc dữ liệu và gán vào danh sách (2 người xem)

[trungtamcnc]

Em có một TKB gồm nhiều lớp, bây giờ cần trích lọc tên giáo viên dạy một số môn ở lớp đó. Mong các bác giúp đỡ.

 

[SA_DQ]

Bạn xài con macro này xem sao

Option Explicit
Sub TKBLop()
 Dim Rng As Range, sRng As Range, Cls As Range
 Dim VTr As Byte
 
 Sheet1.Select:                  Set Rng = Range([A1], [A65500].End(xlUp))
 For Each Cls In Range([c6], [c99].End(xlUp))
   Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlPart)
   If Not sRng Is Nothing Then
      VTr = InStr(sRng.Value, "-") + 1
      Cls.Offset(, 1).Value = Mid(sRng.Value, VTr, 9)
   End If
 Next Cls
End Sub

 

[concogia]

Em có một TKB gồm nhiều lớp, bây giờ cần trích lọc tên giáo viên dạy một số môn ở lớp đó. Mong các bác giúp đỡ.

"Chơi" hai kiểu luôn: hàm tự tạo & công thức

Public Function Gv(Vung As Range, Ten As String) As String
    Dim Cll As Range, J As Integer
        For Each Cll In Vung
            J = InStr(1, Cll, Ten)
            If J > 0 Then Gv = Right(Cll, Len(Cll) - Len(Ten) - 1): Exit Function
        Next
End Function

 

[ThuNghi]

Option Explicit
Sub TKBLop()
 Dim Rng As Range, sRng As Range, Cls As Range
 Dim VTr As Byte
 
 Sheet1.Select:                  Set Rng = Range([A1], [A65500].End(xlUp))
 For Each Cls In Range([c6], [c99].End(xlUp))
   Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlPart)
   If Not sRng Is Nothing Then
      VTr = InStr(sRng.Value, "-") + 1
      Cls.Offset(, 1).Value = Mid(sRng.Value, VTr, 9)
   End If
 Next Cls
End Sub

Em xin "chọt" cho thư giãn, nếu môn Văn có 2 GV dạy thì sao.
Cụ thể:

Văn-Linh
Văn-xxxx

Hay những môn học không cụ thể như trên và lớp 10A99 có học thêm môn GPE ...
Theo em nên dùng code sau tổng quát hơn.

Option Explicit
Sub TKBMon_GV()
 Dim Dic As Object, i As Long, s As Long
 Dim Arr(), ArrKQ(), sTmp As String, sTemp
 Set Dic = CreateObject("Scripting.Dictionary")
 Sheet1.Select
 Arr = Range([A2], [A65500].End(xlUp))
 s = 0: ReDim ArrKQ(1 To UBound(Arr), 1 To 2)
 For i = 1 To UBound(Arr)
 sTmp = Replace(Trim(Arr(i, 1)), Space(1), Space(0))
  If Not Dic.Exists(sTmp) Then
    Dic.Add sTmp, Nothing
    s = s + 1
    sTemp = Split(sTmp, "-")
    ArrKQ(s, 1) = sTemp(0)
    ArrKQ(s, 2) = sTemp(1)
  End If
 Next i
 With Range("C6")
  .Resize(UBound(Arr), 2).ClearContents
  .Resize(s, 2) = ArrKQ
 End With
 Erase Arr, ArrKQ, sTemp: Set Dic = Nothing
End Sub

Cám ơn Bác.