Code lọc 3 điều kiện

Liên hệ QC
ngh_khanh

ngh_khanh

Thành viên mới
Tham gia
14/2/11
Bài viết
45
Được thích
25
Em có 1 ví dụ nhỏ thế này, nhờ AC thiết lập cho em code để nó lọc dư liệu sau khi thoả mãn 3 điều kiện.
Cám ơn AC nhiều!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Upvote 0
ngh_khanh đã viết:
Anh ơi, anh sửa lại dùm em nhé! Em không hiểu phân Array lắm!
Nhấp chuột vào đây để mở rộng...
PHP: 
Dim endR As Long, iR As Long, iC As Long, s As Long
Dim fDate As Date, eDate As Date
Dim Arr(), ArrKq()
Dim sMaHH As String
Sub TaoBaoCao()
With Sheets("Sheet2")
  .Range("A6:D100").ClearContents
  fDate = .[B2]: eDate = .[D2]
  sMaHH = .[B3]
End With
With Sheets("Sheet1")
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr = .Range("A3:F" & endR).Value
End With
s = 0
ReDim ArrKq(1 To endR, 1 To 4)
For iR = 1 To UBound(Arr)
  If Arr(iR, 2) = sMaHH Then
    If CVDate(Arr(iR, 1)) <= eDate Then
      If CVDate(Arr(iR, 1)) >= fDate Then
        s = s + 1
        For iC = 1 To 4
          ArrKq(s, iC) = Arr(iR, iC + 2)
        Next iC
      End If
    End If
  End If
Next iR
If s > 0 Then
  With Sheets("Sheet2")
    .[A6].Resize(s, 4).Value = ArrKq
  End With
End If
Erase ArrKq, Arr
End Sub
Dùng code sau và code sự kiện
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$3" Then
  TaoBaoCao
End If
End Sub
 
Upvote 0
ngh_khanh đã viết:
Anh ơi, anh sửa lại dùm em nhé! Em không hiểu phân Array lắm!
Nhấp chuột vào đây để mở rộng...
Bạn có thể làm theo cách đơn giản sau:
- AutoFilter cột ngày theo điều kiện >=Ngày đầu And <= Ngày cuối
- AutoFilter cột Mã theo điều kiện = Mã yêu cầu lọc
- Copy kết quả sau filter và paste sang
Quá trình trên được thực hiện bằng tay kết hợp với chức năng record macro ---> sau đó vào chỉnh lại code tí xíu là xài được rồi
(Phương pháp Array cho tốc độ rất cao nhưng chỉ nên dùng khi bạn thật sự giỏi VBA và khi dữ liệu của bạn quá nhiều, cở vài chục ngàn dòng)
 
Upvote 0
ngh_khanh đã viết:
Anh ơi, anh sửa lại dùm em nhé! Em không hiểu phân Array lắm!
Nhấp chuột vào đây để mở rộng...
Nếu không nuốt nổi "thằng" mảng thì xơi tạm "em" này thử xem:
Right Click sheet2 ==> View Code ==> chép cái này vào
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, dK As Range
    Set Vung = Sheets("sheet1").[a2].CurrentRegion
    Set dK = Union([B2], [D2])
        If Target.Address = "$B$3" Then
            If Target.Value <> "" And Application.WorksheetFunction.CountA(dK) < 2 Then
                MsgBox "Không nhap ngày vào thì loc bang gì ha TROI ???"
            Else
                [A5].CurrentRegion.Clear
                With Vung
                    .AutoFilter Field:=1, Criteria1:=">=" & [B2].Value, Operator:=xlAnd, Criteria2:="<=" & [D2].Value
                    .AutoFilter Field:=2, Criteria1:=[b3].Value
                    .SpecialCells(12).Copy [A5]
                    .AutoFilter
                End With
            End If
        End If
End Sub
Thân
 
Upvote 0
concogia đã viết:
Nếu không nuốt nổi "thằng" mảng thì xơi tạm "em" này thử xem:
Right Click sheet2 ==> View Code ==> chép cái này vào
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, dK As Range
    Set Vung = Sheets("sheet1").[a2].CurrentRegion
    Set dK = Union([B2], [D2])
        If Target.Address = "$B$3" Then
            If Target.Value <> "" And Application.WorksheetFunction.CountA(dK) < 2 Then
                MsgBox "Không nhap ngày vào thì loc bang gì ha TROI ???"
            Else
                [A5].CurrentRegion.Clear
                With Vung
                    .AutoFilter Field:=1, Criteria1:=">=" & [B2].Value, Operator:=xlAnd, Criteria2:="<=" & [D2].Value
                    .AutoFilter Field:=2, Criteria1:=[b3].Value
                    .SpecialCells(12).Copy [A5]
                    .AutoFilter
                End With
            End If
        End If
End Sub
Thân
Nhấp chuột vào đây để mở rộng...
Cái dòng
Mã: 
AutoFilter Field:=1, Criteria1:=">=" & [B2].Value, Operator:=xlAnd, Criteria2:="<=" & [D2].Value
sẽ không bao giờ chạy được trong đa số trường hợp
Có chăng phải sửa thành vầy:
Mã: 
.AutoFilter 1, ">=" & Clng([B2].Value), 1, "<=" & Clng([D2].Value)
Không biết anh Cò đã thử code trên chưa? (với Control Panel định dang dd/mm/yyyy)
 
Lần chỉnh sửa cuối:
Upvote 0
concogia đã viết:
Nếu không nuốt nổi "thằng" mảng thì xơi tạm "em" này thử xem:
Right Click sheet2 ==> View Code ==> chép cái này vào
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, dK As Range
    Set Vung = Sheets("sheet1").[a2].CurrentRegion
    Set dK = Union([B2], [D2])
        If Target.Address = "$B$3" Then
            If Target.Value <> "" And Application.WorksheetFunction.CountA(dK) < 2 Then
                MsgBox "Không nhap ngày vào thì loc bang gì ha TROI ???"
            Else
                [A5].CurrentRegion.Clear
                With Vung
                    .AutoFilter Field:=1, Criteria1:=">=" & [B2].Value, Operator:=xlAnd, Criteria2:="<=" & [D2].Value
                    .AutoFilter Field:=2, Criteria1:=[b3].Value
                    .SpecialCells(12).Copy [A5]
                    .AutoFilter
                End With
            End If
        End If
End Sub
Thân
Nhấp chuột vào đây để mở rộng...
---
Theo hướng dẩn của anh, em đã "xơi" tạm "em" này nhưng mà không hiểu lỗi chổ nào nhờ anh xem và hướng dẩn giúp. Cám ơn
*Test code của anh concogia nên chưa xem bài NDU
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tam8678 đã viết:
---
Theo hướng dẩn của anh, em đã "xơi" tạm "em" này nhưng mà không hiểu lỗi chổ nào nhờ anh xem và hướng dẩn giúp. Cám ơn
*Test code của anh concogia nên chưa xem bài NDU
Nhấp chuột vào đây để mở rộng...
Anh sửa thành vầy xem:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  If Target.Address = "$B$3" Then
    Range("A5:F10000").Clear
    With Sheets("sheet1").Range("A2").CurrentRegion
      .AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
      .AutoFilter 2, Range("B3").Value
      .SpecialCells(12).Copy Range("A5")
      .AutoFilter
    End With
  End If
End Sub
------------------------
concogia đã viết:
Hihi, bạn nhập ngày giống như dữ liệu bên sheet1 là ...."xơi tuốt tuồn tuột"
Thân
Nhấp chuột vào đây để mở rộng...
Vấn đề nằm ở chổ: Trên máy anh code chạy được còn máy người khác thì thua ---> AutoFilter với điều kiện ngày tháng phải hết sức cần thận, không đơn giản anh viết Criteria1:=">=" & [B2].Value là máy nó hiểu đâu
(cái vụ này đã đề cập trên diễn đàn lâu rồi mà)
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Cái dòng
Mã: 
AutoFilter Field:=1, Criteria1:=">=" & [B2].Value, Operator:=xlAnd, Criteria2:="<=" & [D2].Value
sẽ không bao giờ chạy được trong đa số trường hợp
Nhấp chuột vào đây để mở rộng...
Có thể nói cụ thể được không hả chú ? và
Có chăng phải sửa thành vầy:
Mã: 
.AutoFilter 1, ">=" & Clng([B2].Value), 1, "<=" & Clng([D2].Value)
Clng: chổ này là sao hả chú?
Cám ơn
 
Upvote 0
tam8678 đã viết:
Có thể nói cụ thể được không hả chú ? và
Có chăng phải sửa thành vầy:
Mã: 
.AutoFilter 1, ">=" & Clng([B2].Value), 1, "<=" & Clng([D2].Value)
Clng: chổ này là sao hả chú?
Cám ơn
Nhấp chuột vào đây để mở rộng...

Clng([B2].Value)để biến giá tri cell B2 thành biến Long thôi mà anh
Nói chung anh cứ nhớ thuộc lòng như vầy: Khi dùng code AutoFilter với điều kiện ngày tháng thì anh BUỘC PHẢI biến điều kiện thành biến Long trước (dùng CLng như em đã làm ở trên) ---> Chắc bắp máy nào cũng chạy
Ẹc... Ẹc...
 
Upvote 0
ndu96081631 đã viết:
Anh sửa thành vầy xem:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$B$3" Then
Range("A5:F10000").Clear
With Sheets("sheet1").Range("A2").CurrentRegion
.AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
.AutoFilter 2, Range("B3").Value
.SpecialCells(12).Copy Range("A5")
.AutoFilter
End With
End If
End Sub
------------------------

Vấn đề nằm ở chổ: Trên máy anh code chạy được còn máy người khác thì thua ---> AutoFilter với điều kiện ngày tháng phải hết sức cần thận, không đơn giản anh viết Criteria1:=">=" & [B2].Value là máy nó hiểu đâu
(cái vụ này đã đề cập trên diễn đàn lâu rồi mà)
Nhấp chuột vào đây để mở rộng...

Em làm thế này sao vẫn chưa được? Anh xem thêm dùm em chút nha!
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  If Target.Address = "$B$3" Then
    Range("A5:D10000").Clear
    With S1.Range([A2], [A65535].End(3))
      .AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
      .AutoFilter 2, Range("B3").Value
      .Offset(1, 2).Resize(, 4).SpecialCells(12).Copy Range("A6")
      .AutoFilter
    End With
  End If
End Sub
 

File đính kèm

Upvote 0
ngh_khanh đã viết:
Em làm thế này sao vẫn chưa được? Anh xem thêm dùm em chút nha!
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  If Target.Address = "$B$3" Then
    Range("A5:D10000").Clear
    With S1.Range([A2], [A65535].End(3))
      .AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
      .AutoFilter 2, Range("B3").Value
      .Offset(1, 2).Resize(, 4).SpecialCells(12).Copy Range("A6")
      .AutoFilter
    End With
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Sai chổ này:
With S1.Range([A2], [A65535].End(3))
Lý ra phải vầy:
With S1.Range(S1.[A2], S1.[A65535].End(3))
Ngoài ra do bạn có filter cột B nên phải Resize vùng trên ít nhất 2 cột (nếu không thì dòng này .AutoFilter 2 sẽ báo lỗi)
Tóm lại, nếu không thích dùng CurrentRegion thì code trên sửa thành:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  If Target.Address = "$B$3" Then
    Range("A5:D10000").Clear
    With S1.Range(S1.[A2], S1.[A65535].End(3)).Resize(, 6)
      .AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
      .AutoFilter 2, Range("B3").Value
      .Offset(, 2).Resize(, 4).SpecialCells(12).Copy Range("A6")
      .AutoFilter
    End With
  End If
End Sub
 
Upvote 0
Em muốn chèn thêm cột bên Sheet2 và đặt tên là STT thì làm thế nào viết code?
 
Upvote 0
Mình sẽ tạo cho bạn thêm cột STT trước cột tên hàng. Và code thêm là:
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  On Error Resume Next
  If Target.Address = "$B$3" Then
    Range("A6:E65535").Clear
    With S1.Range(S1.[A2], S1.[A65535].End(3)).Resize(, 6)
      .AutoFilter 1, ">=" & CLng(Range("B2").Value), 1, "<=" & CLng(Range("D2").Value)
      .AutoFilter 2, Range("B3").Value
      .Offset(1, 2).Resize(, 4).SpecialCells(12).Copy Range("B6")
      .AutoFilter
    End With
    With S2.Range("A5").CurrentRegion
        If .Rows.Count > 1 Then
            .Resize(, 1).SpecialCells(4).Value = Evaluate("row(R:R)")
        End If
    End With
  End If
End Sub
 

File đính kèm

Upvote 0
ndu96081631 đã viết:
Clng([B2].Value)để biến giá tri cell B2 thành biến Long thôi mà anh
Nói chung anh cứ nhớ thuộc lòng như vầy: Khi dùng code AutoFilter với điều kiện ngày tháng thì anh BUỘC PHẢI biến điều kiện thành biến Long trước (dùng CLng như em đã làm ở trên) ---> Chắc bắp máy nào cũng chạy
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Anh ơi, anh nói rõ hơn chút nữa "CLng" nhé! Em không hiểu rõ chỗ này!?
 
Upvote 0
ndu96081631 đã viết:

Clng([B2].Value)để biến giá tri cell B2 thành biến Long thôi mà anh
Nói chung anh cứ nhớ thuộc lòng như vầy: Khi dùng code AutoFilter với điều kiện ngày tháng thì anh BUỘC PHẢI biến điều kiện thành biến Long trước (dùng CLng như em đã làm ở trên) ---> Chắc bắp máy nào cũng chạy
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Có thể dùng Value2 thay vì Value, cũng xơi tuốt tuột

.AutoFilter 1, ">=" & Range("B2").Value2, 1, "<=" & Range("D2").Value2
Mã: 
[B]Value2[/B] Returns or sets the cell value. Read/write [B]Variant[/B]. [B]Syntax[/B]
 [B][I]expression[/I].Value2[/B]
 [I]expression[/I]   A variable that represents a [B]Range[/B] object.
 [B]Remarks[/B]

The only difference between this property and the [B]Value[/B] property is  that the [B]Value2[/B] property [COLOR=red]doesn’t use the [B]Currency[/B] and [B]Date[/B]  data types[/COLOR]
 
Lần chỉnh sửa cuối:
Upvote 0
ptm0412 đã viết:
Có thể dùng Value2 thay vì Value, cũng xơi tuốt tuột
Nhấp chuột vào đây để mở rộng...
Cái thằng Value2 này em xài từ ngày mới vào diễn đàn, vậy mà bây giờ sư phụ nhắc lại thì mới thấy rằng mình.. đã quên tuốt
Tức là cái gì để lâu quá không dùng thì có thể bị... chuột tha mất
Ẹc... Ẹc...
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
2
Đọc
81
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
307
Đọc
22K
kunkoi9390
K
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
6
Đọc
2K
tranhungdao12a3
T
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
4
Đọc
155
cuongtri
C
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
45
Đọc
14K
ngocthu90
ngocthu90
Uyên dương Hoya
Lỗi định dạng font chữ trong excel
Trả lời
3
Đọc
126
ptm0412
ptm0412
T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
12
Đọc
447
VetMini
V
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
8
Đọc
665
nguyendang95
N
ntnguyentam1907
Lấy bảng dữ liệu chứng khoán về excel
2
Trả lời
22
Đọc
3K
nguyendang95
N
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
5
Đọc
774
hoangtuan.net
hoangtuan.net
HONGVY91
Đếm số lượng 2 cột và đếm không trùng
Trả lời
2
Đọc
139
hoangtuaotrang_hp_vn
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
3
Đọc
199
hanhlx88
hanhlx88
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
73
Đọc
10K
HeSanbi
HeSanbi
L
Folder chứa chương trình bị khóa bởi Lock folder
2
Trả lời
28
Đọc
25K
qthangvphaui
Q
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
4
Đọc
160
phambahoang
P
N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
85
HUONGHCKT
H
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
209
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
258
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom