Giúp Viết Code Lọc Dữ Liệu Có Điều Kiện

[khamha]

Chào Các Bạn, Mình Có Một Bảng Tính Nhờ Các Bạn Giúp Viết Code Lọc Dữ Liệu Có Điều Kiện Như Sau:
Ví Dụ: Sheet1 Là Sheet Nhập Liệu Và Sheet 2 Và 3 Là Sheet Lọc Có Điều Kiện, Điều Kiện Lọc Là Sheet 2 Và 3 Sẽ Có Hai Nút Để Lọc Theo Năm Và Tháng, Khi Mình Chọn Năm Thì Tất Cả Các Dữ Liệu Của Năm Đã Chọn Sẽ Hiện Nên, Sau Đó Mình Chọn Thêm Tháng Thì Dữ Liệu Của Tháng Trong Năm Đã Chọn Ở Bước Đầu Sẽ Hiện Nên.
Rất Mong Được Sự Giúp Đỡ Từ Các Bạn, Cảm Ơn Nhiều

 

[ThuNghi]

Chào Các Bạn, Mình Có Một Bảng Tính Nhờ Các Bạn Giúp Viết Code Lọc Dữ Liệu Có Điều Kiện Như Sau:
Ví Dụ: Sheet1 Là Sheet Nhập Liệu Và Sheet 2 Và 3 Là Sheet Lọc Có Điều Kiện, Điều Kiện Lọc Là Sheet 2 Và 3 Sẽ Có Hai Nút Để Lọc Theo Năm Và Tháng, Khi Mình Chọn Năm Thì Tất Cả Các Dữ Liệu Của Năm Đã Chọn Sẽ Hiện Nên, Sau Đó Mình Chọn Thêm Tháng Thì Dữ Liệu Của Tháng Trong Năm Đã Chọn Ở Bước Đầu Sẽ Hiện Nên.
Rất Mong Được Sự Giúp Đỡ Từ Các Bạn, Cảm Ơn Nhiều

Tôi thấy 2 sheet D_Ni và N_Ma giống nhau mà.
Bạn nên cố đưa 1 vài dòng dữ liệu và vài dòng kết quả. Mọi người sẽ trả lờ nhanh hơn.
Cám ơn bạn rất nhiều.

 

[SA_DQ]

Đúng như ThuNghi nói đó nghen, rút kinh nghiệm lần sau là vừa.

Option Explicit
Public Sh As Worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rng As Range
 Dim eRw As Long, Col As Byte
 Set Sh = Sheets("SL"):           Set Rng = Sh.[b2].CurrentRegion.Offset(1)
 eRw = Rng.Rows.Count:            Col = Rng.Columns.Count
 If Not Intersect(Target, [D1]) Is Nothing Then
   [E3].Interior.ColorIndex = 2
   [A3].Resize(eRw, Col).ClearContents
   AdvFilter Rng, Sh.Range("AX1:AX2")
   Sh.[BB2].CurrentRegion.Offset(1).Copy Destination:=[A3]
 ElseIf Not Intersect(Target, [E1]) Is Nothing Then
   [A3].Resize(eRw, Col).ClearContents
   AdvFilter Rng, Sh.Range("AX1:AY2")
   Sh.[BB2].CurrentRegion.Offset(1).Copy Destination:=[A3]
 End If
End Sub

[B]Sub AdvFilter(Rng As Range, RngC As Range)[/B]
 Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=RngC, CopyToRange:=Sh.Range("BA2:CO2")
[B]End Sub[/B]

& như là việc fải trả giá: Mình làm cho bạn ở trang tính thứ 2 thôi; Trang 3 bạn thử tham khảo để tiếp tục đi!

 

[khamha]

Đúng Ý Mình Rồi, Nhưng Mà Lúc Lọc Có Hơi Chậm Một Tý, Mình Sợ Lúc Có Nhiều Dữ Liệu Sẽ Càng Chậm Hơn, Bạn Còn Có Cách Nào Nữa Không?

 

[ThuNghi]

Đúng Ý Mình Rồi, Nhưng Mà Lúc Lọc Có Hơi Chậm Một Tý, Mình Sợ Lúc Có Nhiều Dữ Liệu Sẽ Càng Chậm Hơn, Bạn Còn Có Cách Nào Nữa Không?

Tôi thấy dùng AdFi là nhanh rồi mà. Có thấy chậm gì đâu.
Để tôi làm theo dạng Arr thử xem có nhanh kg?

 

[khamha]

Cảm Ơn ý Tốt Của Bạn Là Phần Còn Lại Mình Phải Tự Tìm Hiểu, Mình Đã Thử Làm Trong Sheet 3 Rồi Nhưng Mà Không Được, Có Gì Bạn Giúp Mình Luôn Nha, Còn Một Khâu Nữa Là Khi Mình Tính Tổng Ở Hàng Thứ 3 Thì Khi Bấm Nút Lọc Dữ Liệu Thì Mất Luôn Cả Công Thức.Xin Cảm Ơn

 

[ThuNghi]

Cảm Ơn ý Tốt Của Bạn Là Phần Còn Lại Mình Phải Tự Tìm Hiểu, Mình Đã Thử Làm Trong Sheet 3 Rồi Nhưng Mà Không Được, Có Gì Bạn Giúp Mình Luôn Nha, Còn Một Khâu Nữa Là Khi Mình Tính Tổng Ở Hàng Thứ 3 Thì Khi Bấm Nút Lọc Dữ Liệu Thì Mất Luôn Cả Công Thức.Xin Cảm Ơn

Bạn dùng thử code sau liệu có nhanh hơn không, thay Sheets("D_Ni").Select cho phù hợp

Option Explicit
Sub Loc01()
Dim ArrSL(), ArrKQ(1 To 10000, 1 To 41), ArrYear(), ArrMonth()
Dim endR As Long, i As Long, k As Long, s As Long, iCol As Long
Dim sYear As Long, sMonth As Long
With Sheets("SL")
  endR = .Cells(65000, 1).End(xlUp).Row - 1
  ArrSL = .Range("A3:AO" & endR).Value
  iCol = .Range("A3:AO" & endR).Columns.Count
  ArrYear = .Range("D3:D" & endR).Value
  ArrMonth = .Range("E3:E" & endR).Value
End With
s = 0
Sheets("D_Ni").Select
Range("A3:AO10000").ClearContents
sYear = Range("D1")
sMonth = Range("E1")
For i = 1 To UBound(ArrYear)
  If ArrYear(i, 1) = sYear Then
    If ArrMonth(i, 1) = sMonth Then
      s = s + 1
      For k = 1 To iCol
        ArrKQ(s, k) = ArrSL(i, k)
      Next
    End If
  End If
Next i
If s = 0 And k = 0 Then Exit Sub
With Range("A3")
  .Resize(s, k - 1).Value = ArrKQ
End With
Erase ArrSL(), ArrKQ(), ArrYear(), ArrMonth()
End Sub

 

[ThuNghi]

Cũng code trên ở bài 7, nếu tôi thêm 1 dòng để đếm thỏa điều kiện

solanM = WF.CountIf(rngM, sMonth)
  solanY = WF.CountIf(rngY, sYear)

và

If y = solanY Or m = solanM Then Exit For

theo code

Sub Loc02()
Dim ArrSL(), ArrKQ(1 To 10000, 1 To 41), ArrYear(), ArrMonth()
Dim endR As Long, i As Long, k As Long, s As Long, iCol As Long
Dim sYear As Long, sMonth As Long
Dim y As Long, m As Long, rngY As Range, rngM As Range, solanY As Long, solanM As Long
Dim WF As WorksheetFunction
Set WF = WorksheetFunction
With Sheets("D_Ni")
  sYear = .Range("D1")
  sMonth = .Range("E1")
End With
With Sheets("SL")
  endR = .Cells(65000, 1).End(xlUp).Row - 1
  ArrSL = .Range("A3:AO" & endR).Value
  iCol = .Range("A3:AO" & endR).Columns.Count
  Set rngY = .Range("D3:D" & endR)
  Set rngM = .Range("E3:E" & endR)
  solanM = WF.CountIf(rngM, sMonth)
  solanY = WF.CountIf(rngY, sYear)
  ArrYear = rngY.Value
  ArrMonth = rngM.Value
End With
s = 0: m = 0: y = 0
Sheets("D_Ni").Select
Range("A3:AO10000").ClearContents
  For i = 1 To UBound(ArrYear)
    If y = solanY Or m = solanM Then Exit For
      If ArrYear(i, 1) = sYear Then
        y = y + 1
        If ArrMonth(i, 1) = sMonth Then
          s = s + 1
          For k = 1 To iCol
            ArrKQ(s, k) = ArrSL(i, k)
          Next
          m = m + 1
        End If
      End If
  Next i
If s = 0 And k = 0 Then Exit Sub
With Range("A3")
  .Resize(s, k - 1).Value = ArrKQ
End With
Set rngY = Nothing: Set rngM = Nothing: Set WF = Nothing
Erase ArrSL(), ArrKQ(), ArrYear(), ArrMonth()
End Sub

Liệu tốc độ có nhanh hơn vì có dùng thêm 1 hàm WF.CountIf
Theo file kèm.
Nhờ các bạn test giúp.
Cám ơn.

 

[ptm0412]

Têêm 1 câu:
If y = solanY Or m = solanM Then Exit For
Liệu tốc độ có nhanh hơn vì có dùng thêm 1 hàm WF.CountIf

Xử lý bằng Array rất nhanh nên chênh lệch giữa chạy For 60.000 dòng rồi thoát và For chạy đủ 65.000 dòng rất khó nhận ra. Chỉ khi nào 10.000 dòng thoát và chạy đủ 65.000 dòng mới thấy sự khác biệt.

Wf.CountIf đúng là có làm chậm lại 1 chút, giả sử làm chậm lại 0.5 giây. Nếu do thoát sớm mà Loc2 làm lợi chỉ có 0.3 giây, thì Loc2 chậm hơn Loc1 0.2 giây. Nếu nhờ thoát sớm mà lợi 0.8 giây, thì Loc2 nhanh hơn 0.3 giây.

Đại khái vậy đó.

 

[khamha]

Đúng như ThuNghi nói đó nghen, rút kinh nghiệm lần sau là vừa.

PHP Code:
Option Explicit
Public Sh As Worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim eRw As Long, Col As Byte
Set Sh = Sheets("SL"): Set Rng = Sh.[b2].CurrentRegion.Offset(1)
eRw = Rng.Rows.Count: Col = Rng.Columns.Count
If Not Intersect(Target, [D1]) Is Nothing Then
[E3].Interior.ColorIndex = 2
[A3].Resize(eRw, Col).ClearContents
AdvFilter Rng, Sh.Range("AX1:AX2")
Sh.[BB2].CurrentRegion.Offset(1).Copy Destination:=[A3]
ElseIf Not Intersect(Target, [E1]) Is Nothing Then
[A3].Resize(eRw, Col).ClearContents
AdvFilter Rng, Sh.Range("AX1:AY2")
Sh.[BB2].CurrentRegion.Offset(1).Copy Destination:=[A3]
End If
End Sub


Code:


Sub AdvFilter(Rng As Range, RngC As Range)
Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=RngC, CopyToRange:=Sh.Range("BA2:CO2")
End Sub

Bạn Ơi Mình Thêm Cột Vào Sheet"SL" 20 Cột , Đến Cột DI,Nhưng Nó Không Lọc Được, Bạn Làm Ơn Sửa Lại Code Cho Mình Với, Cảm Ơn Bạn Nhiều

 

[SA_DQ]

Bạn Ơi Mình Thêm Cột Vào Sheet"SL" 20 Cột , Đến Cột DI,Nhưng Nó Không Lọc Được, Bạn Làm Ơn Sửa Lại Code Cho Mình Với,

Trong macro nó đã trưng dụng cột 'AX & cột 'Ay' làm điều kiện lọc
Giờ bạn cần đến cột 'DL' thì hầu như fải sửa lại toàn bộ macro rồi
(Mà mình thấy bạn chỉ thêm 20 cột thì đâu có đến 'Dl; chỉ đến 'BL' thôi mà?!

Nhưng ngán quá đi mất!. . . '

 

[khamha]

[/FONT]

Trong macro nó đã trưng dụng cột 'AX & cột 'Ay' làm điều kiện lọc
Giờ bạn cần đến cột 'DL' thì hầu như fải sửa lại toàn bộ macro rồi
(Mà mình thấy bạn chỉ thêm 20 cột thì đâu có đến 'Dl; chỉ đến 'BL' thôi mà?!

Nhưng ngán quá đi mất!. . . '

Bạn Làm Ơn Cố Gắng Giúp Mình Một Lần Nữa Đi, Đến Mức Này Rồi Mà Không Hoàn Thành Thì Phí Công Quá