Lọc dữ liệu khi tiêu đề bảng có nhiều dòng

Liên hệ QC

lucbinh2013

Thành viên mới
Tham gia
14/6/13
Bài viết
7
Được thích
1
Nhờ các A/C giúp code của e nếu lọc tiêu đề có 1 dòng thì ok, nếu tiêu đề có 2 dòng thì không lọc được.
(chỉ cần nhập mã môn ở sheet IN là sẽ tự động lọc). Cám ơn A/C nhiều
 

File đính kèm

  • _KetQua_2.xlsm
    25 KB · Đọc: 5
Nhờ các A/C giúp code của e nếu lọc tiêu đề có 1 dòng thì ok, nếu tiêu đề có 2 dòng thì không lọc được.
(chỉ cần nhập mã môn ở sheet IN là sẽ tự động lọc). Cám ơn A/C nhiều
Thử dùng file này xem sao. Hãy thay đổi Ô L3 của Sh In và xem kết quả.
Nếu dùng được bạn nên xóa bỏ Modul1 cho nhẹ file.
 

File đính kèm

  • _KetQua_2.xlsm
    27.6 KB · Đọc: 11
Nhờ các A/C giúp code của e nếu lọc tiêu đề có 1 dòng thì ok, nếu tiêu đề có 2 dòng thì không lọc được.
(chỉ cần nhập mã môn ở sheet IN là sẽ tự động lọc). Cám ơn A/C nhiều
Tôi sửa lại code Loc() của bạn
Bạn tham khảo nhé!
PHP:
Sub Loc()
    Dim lR As Long
    Dim VisibleRange As Range, SourceRange As Range
    
    'Tat cap nhat man hinh
    Application.ScreenUpdating = False
    
    With Sheet1
        'Toan bo du lieu goc
        Set SourceRange = .Range("A1").CurrentRegion
        'Tat che do Filter
        .AutoFilterMode = False
        'Filter du lieu
        .Range("A2:J2").AutoFilter Field:=2, Criteria1:=Sheet2.Range("L3")
        'Du lieu da loc
        Set VisibleRange = SourceRange.SpecialCells(xlCellTypeVisible)
    End With
      
    'Tat kiem tra su kien
    Application.EnableEvents = False
    'Unhide toan bo cac dong
    Sheet2.Range("A5:J100").EntireRow.Hidden = False
    'Xoa ket qua cu
    Sheet2.Range("A5:J100").ClearContents
    'Kiem tra xem loc co ket qua hay khong?
    If VisibleRange.Rows.Count > 2 Or VisibleRange.Areas.Count > 1 Then
        With Sheet2
            'Copy du lieu da loc
            VisibleRange.Copy .Range("A5")
            'Xac dinh dong cuoi co du lieu
            lR = .Range("B" & Rows.Count).End(xlUp).Row
            'An cac dong trong
            .Rows((lR + 1) & ":100").EntireRow.Hidden = True
        End With
        Call SoThuTu
    Else    'Khong co ket qua loc thi thong bao
        MsgBox "Khong co ket qua loc du lieu", vbCritical, "GPE"
    End If
    
    'Tat che do Filter
    Sheet1.AutoFilterMode = False
    Set VisibleRange = Nothing
    'Bat kiem tra su kien
    Application.EnableEvents = True
    
    'Bat cap nhat man hinh
    Application.ScreenUpdating = True
End Sub
 
Tôi sửa lại code Loc() của bạn
Bạn tham khảo nhé!
PHP:
Sub Loc()
    Dim lR As Long
    Dim VisibleRange As Range, SourceRange As Range
   
    'Tat cap nhat man hinh
    Application.ScreenUpdating = False
   
    With Sheet1
        'Toan bo du lieu goc
        Set SourceRange = .Range("A1").CurrentRegion
        'Tat che do Filter
        .AutoFilterMode = False
        'Filter du lieu
        .Range("A2:J2").AutoFilter Field:=2, Criteria1:=Sheet2.Range("L3")
        'Du lieu da loc
        Set VisibleRange = SourceRange.SpecialCells(xlCellTypeVisible)
    End With
     
    'Tat kiem tra su kien
    Application.EnableEvents = False
    'Unhide toan bo cac dong
    Sheet2.Range("A5:J100").EntireRow.Hidden = False
    'Xoa ket qua cu
    Sheet2.Range("A5:J100").ClearContents
    'Kiem tra xem loc co ket qua hay khong?
    If VisibleRange.Rows.Count > 2 Or VisibleRange.Areas.Count > 1 Then
        With Sheet2
            'Copy du lieu da loc
            VisibleRange.Copy .Range("A5")
            'Xac dinh dong cuoi co du lieu
            lR = .Range("B" & Rows.Count).End(xlUp).Row
            'An cac dong trong
            .Rows((lR + 1) & ":100").EntireRow.Hidden = True
        End With
        Call SoThuTu
    Else    'Khong co ket qua loc thi thong bao
        MsgBox "Khong co ket qua loc du lieu", vbCritical, "GPE"
    End If
   
    'Tat che do Filter
    Sheet1.AutoFilterMode = False
    Set VisibleRange = Nothing
    'Bat kiem tra su kien
    Application.EnableEvents = True
   
    'Bat cap nhat man hinh
    Application.ScreenUpdating = True
End Sub
Dạ cám ơn rất nhiều, em làm dược rồi ạ
 
Web KT
Back
Top Bottom