Lọc và lập danh sách

[hoangvuluan]

Lọc Tự Động bằng VBA

Chào các bạn, mình đưa ra ở đây 1 macro dùng trong việc lọc tự động. Các bạn xem và cho ý kiến nhé!

Sub autoFilt()
  ' Dung gia tri cua su chon hien thoi lam dieu kien loc tu dong
  ' co the chon 1 hoac 2 o, voi 2 o: neu khac cot thi loc theo nghia "and", cu`ng cot thi theo nghia "or"
  ' co the chon gia tri ben trong vu`ng loc hoac ngay tren, ngay duoi (voi khoang cach toi da la 5 do`ng, toi thieu 1 do`ng)
  Dim s As Worksheet
  Dim r As Range
  Dim c As Range, c1 As Range, c2 As Range
  Dim cri As Variant, cri1 As Variant, cri2 As Variant, fie1, fie2
  Set s = ActiveSheet
  Set c = Application.Selection  'ActiveCell
  Set c1 = c.Cells(1, 1)
  Set c2 = c1
  cri1 = [c1]
  cri2 = cri1
  If c.Areas.Count = 1 Then
    If c.Rows.Count > 1 Then
        Set c2 = c.Cells(2, 1)
        cri2 = [c2]
    ElseIf c.Columns.Count > 1 Then
        Set c2 = c.Cells(1, 2)
        cri2 = [c2]
    Else
        cri2 = ""
    End If
  ElseIf c.Areas.Count > 1 Then
        Set c2 = c.Areas(2).Cells(1, 1)
        cri2 = [c2]
  End If
  
  
  s.AutoFilterMode = False
  
  On Error Resume Next
  Set r = s.Range(s.Name)
  ' Neu tren Sheet da co mot vung dat trung ten voi ten sheet thi dung vung nay,
  ' neu chua co, thi se tu dong tim.
  
  If Err.Number <> 0 Then Set r = c.CurrentRegion  ' Gia tri loc nam trong vung can loc
  
  If r.Cells.Count < 3 Then  '.Rows.Count = 1 Then  ' Gia tri loc nam ngoai vung can loc
    If Len(r.Offset(5, 0).Cells(1, 1)) < 1 Then
      Set r = r.Offset(-5, 0).CurrentRegion     ' dich xuong 5 dong de xac dinh vung can loc
    Else
      Set r = r.Offset(5, 0).CurrentRegion      ' dich len 5 dong de xac dinh vung can loc
    End If
  End If
  
  If cri1 = "" Then
    r.AutoFilter
  Else
    fie1 = c1.Column + 1 - r.Column ' tinh toan vi tri cua cot se loc
    fie2 = c2.Column + 1 - r.Column ' tinh toan vi tri cua cot se loc
    ' neu gia tri la so hoac bieu thuc so sanh thi khong noi them dau *
    If ((Not IsNumeric(cri1)) And (Left(cri1, 1) Like "[!<>=?]")) Then cri1 = cri1 & "*"
    If ((Not IsNumeric(cri2)) And (Left(cri2, 1) Like "[!<>=?]")) Then cri2 = cri2 & "*"
    If c1.Column = c2.Column Then
        r.AutoFilter Field:=fie1, Criteria1:=cri1, Operator:=xlOr, Criteria2:=cri2
    Else
        r.AutoFilter Field:=fie1, Criteria1:=cri1
        r.AutoFilter Field:=fie2, Criteria1:=cri2
    End If
  End If
  Set s = Nothing
  Set r = Nothing
  Set c = Nothing
  Set c1 = Nothing
  Set c2 = Nothing
End Sub