Xin chào befaint,
Bài này nếu lập trình thì điều kiện cột B1 split ra một mảng, dò theo vùng bên sheet order ra mảng mới rồi gán xuống sheet
Cảm ơn bạn đã quan tâm, nếu có thể nhờ bạn giúp đỡ OT theo cách này với ạ:
Product Category có nhiều giá trị giống customer không bạn
Có bạn ạ, mỗi giá trị ngăn cách nhau bởi dấu ";" bạn ạ
Option Explicit
Private Function CheckCriteria(ByVal strChecking As String, ByVal strCriteria As String, _
Optional ByVal blnMatchCase As Boolean = False) As Boolean
'Tra ve True neu tim thay chuoi dieu kien trong strChecking'
'strChecking: Chuoi can kiem tra'
'strCriteria: Chuoi chua cac dieu kien loc'
' Neu khong nhap gi (strCriteria = Empty) tuc la thoa moi dieu kien'
'blnMatchCase: True - phan biet chu hoa/ thuong va nguoc lai. Mac dinh False '
Const strDeli = ";"
Dim item As Variant, strFind As String, MatchCase As VbCompareMethod
If Len(strCriteria) = 0 Then CheckCriteria = True: Exit Function
If blnMatchCase = False Then MatchCase = vbTextCompare Else MatchCase = vbBinaryCompare
For Each item In VBA.Split(strCriteria, strDeli)
strFind = item
If InStr(1, strChecking, strFind, MatchCase) > 0 Then
CheckCriteria = True
Exit For
End If
Next item
End FunctionBác befaint lẹ quá mà 4h mình tan ca rồi nên nếu chưa ổn thì tối mình mới xem giúp bạn được, bạn thông cảm nhé. (mình mới viết được nửa đường
)Dùng Power query
Bạn thử code nếu lọc tất cả thì bỏ trống nhé.
Sub loc()
Dim arr, kq, i As Long, lr As Long, T1, T2, a As Long, b As Integer, c As Integer, dk As String, dks As String
Dim m As Boolean, n As Boolean, k As Integer, j As Integer
With Sheets("Orders")
lr = .Range("H" & Rows.Count).End(xlUp).Row
arr = .Range("A2:J" & lr).Value
ReDim kq(1 To UBound(arr), 1 To 10)
End With
With Sheets("Filter")
T1 = Split(";" & .Range("b1").Value, ";")
T2 = Split(";" & .Range("b2").Value, ";")
b = UBound(T1)
c = UBound(T2)
For i = 1 To UBound(arr)
dk = arr(i, 8)
dks = arr(i, 10)
m = False: n = False
For k = 1 To b
If InStr(dk, T1(k)) Then
m = True
Exit For
End If
Next k
For k = 1 To c
If InStr(dks, T2(k)) Then
n = True
Exit For
End If
Next k
If m = True And n = True Then
a = a + 1
For j = 1 To 10
kq(a, j) = arr(i, j)
Next j
End If
Next i
lr = .Range("H" & Rows.Count).End(xlUp).Row
If lr > 3 Then .Range("A4:J" & lr).ClearContents
If a Then .Range("A4:J4").Resize(a).Value = kq
End With
End SubDạ OT muốn sử dụng VBA bài này Bạn ạ, cảm ơn bạn nhiều.
Cảm ơn befaint, OT sẽ code thử 1 sub để ứng dụng hàm "CheckCriteria" của Bạn ạ.
Xin chào snow25,
Bạn xóa cái dấu * ở cột B2 đi thì có kết quả.
Cảm ơn @snow25 nhiều ạ,
A! OT xử lý được rồi cảm ơn @snow25 nhiều ạ.
...
T1 = Split(";" & UCase(.Range("b1").Value), ";")
T2 = Split(";" & UCase(.Range("b2").Value), ";")
...
dk = UCase(arr(i, 8))
dks = UCase(arr(i, 10))
...Bạn tìm hiểu lại cấu trúc hàm instr xem sao, chỗ vbtextcompare với vbbinarycompare có thể sẽ gọn hơn
Dạ thôi Bạn ạ, rẹt cái ra kết quả luôn là ưng lắm rồi ạ, còn gọn & đẹp thì để sau nếu cái đầu của OT nó được cải thiện hơn ạ.
Có cách nào bỏ 2 biến "m" và "n" không?
Con chào Bác @HieuCD ,Có cách nào bỏ 2 biến "m" và "n" không?
Trời ạ, mình chỉ gợi ý code gọn và chạy nhanh hơn chút xíu mờ
Dạ vầng Bác ơi, con cũng thấy cần thêm mấy chỗ đó ạ.
Khuya rồi, chúc ngủ ngon
Dạ vầng, Bác cũng nghỉ đi ạ.
Lồng 2 cái vòng lặp for vào nhau có nhanh hơn và gọn hơn anh à.Có cách nào bỏ 2 biến "m" và "n" không?
Bác có thể hướng dẫn em cách làm file này bằng query được không ạ
Có khi nào muốn chọn Profit =0 hay <0 không? Hay luôn chọn >0.
Ùi, con chào Thầy ạ.
Xử lý các điều kiện "<", "<=", "=", ">=", ">" không phải chuyện dễ.
Dạ vầng Thầy ạ, vậy có thể thiết kế thêm một ô nào nữa để lựa chọn các điều kiện "<", "<=", "=", ">=", ">" này được không ạ Thầy?
Bạn thử code này xem đúng yêu cầu chưa:
Option Explicit
Sub NTKTNN()
Dim sArr(), dArr(), CusName, ProCat, fDate As Long, tDate As Long, Profit As String, Bo As Boolean
Dim i As Long, J As Long, K As Long
Application.ScreenUpdating = False
With Sheets("Filter")
CusName = Split(.Range("B1").Value, ";")
ProCat = Split(.Range("B2").Value, ";")
fDate = .Range("D1").Value
tDate = .Range("D2").Value
Profit = .Range("E2").Value
End With
With Sheets("Orders")
sArr = .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Rows).Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr, 1)
If UBound(CusName) >= 0 Then
For J = 0 To UBound(CusName)
If InStr(1, sArr(i, 8), CusName(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I
Bo = False
End If
If UBound(ProCat) >= 0 Then
For J = 0 To UBound(ProCat)
If InStr(1, sArr(i, 10), ProCat(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I
Bo = False
End If
If fDate > 0 And tDate > 0 Then
If sArr(i, 2) >= fDate And sArr(i, 2) <= tDate Then Bo = True
If Bo = False Then GoTo Next_I
Bo = False
End If
If Profit <> "" Then
If Evaluate(sArr(i, 6) & Profit) Then Bo = True
If Bo = False Then GoTo Next_I
End If
K = K + 1
For J = 1 To UBound(sArr, 2)
dArr(K, J) = sArr(i, J)
Next
Next_I:
Next
End With
Sheets("Filter").Range("A4:J10000").ClearContents
Sheets("Filter").Range("A4").Resize(UBound(sArr), UBound(sArr, 2)) = dArr
Application.ScreenUpdating = True
End SubMỗi vòng lặp lại phải tính lại UBound(CusName)
Dùng For each thì không cần kiểm tra Ubound.
Góp ý rất hay bác ạ, đúng là for each thì không cần phải kiểm tra ubound. Nhưng nếu không kiểm tra vậy thì một số trường hợp không có điều kiện (người để trống) code vẫn duyệt qua nó (em đang ví dụ với cusname), như vậy nó sẽ tính cái boolean là false và next sang i khác ạ
Thì mình kiểm tra và oánh dấu ngay từ đầu ấy.
Sao em thấy hình như bớt được khúc if nhưng phải tạo nhiều biến hơn phải không bác?
Ợ. Code xem ở giải thuật chứ đâu đi đếm biến với đếm dòng. @@Sao em thấy hình như bớt được khúc if nhưng phải tạo nhiều biến hơn phải không bác?
Thì em cũng biết code ai đâu đi đếm biến và dòng
, nhưng em chỉ muốn biết theo cách đó có tối ưu hơn không, giả sử hai code tương đương nhau thì vẫn nên tiết kiệm biến và dòng cho dễ nhìn chứ ạDùng ADO để Select bảng ban đầu. Với điều kiện ghép như [Customer name] dạng "a;b;c" ta dùng Replace và nối chuỗi để thay thế thành ([Customer name] like "%a%" OR [Customer name] like "%b%" OR [Customer name] like "%c%") rồi đưa vào điều kiện where thôi. Với điều kiện > hay >= dùng nối chuỗi bình thường.
Mình thường viết kiểu nầy
...
With Sheets("Filter")
CusName = Split(";" & .Range("B1").Value, ";")
...
For i = 1 To UBound(sArr, 1)
For J = 1 To UBound(CusName)
If InStr(1, sArr(i, 8), CusName(J), 1) = 0 Then GoTo Next_I
Next
...Ủa bác Hiếu, ubound của mảng split gốc 0 mà bác, với lại mảng cusname có nhiều phần tử, nếu duyệt phần tử đầu không có thì duyệt tiếp chứ theo em thấy code đó nếu gặp phần tử đầu tiên không có là next luôn rồi bác?
CusName = Split(";" & .Range("B1").Value, ";")
...
With Sheets("Filter")
CusName = Split(";" & .Range("B1").Value, ";")
...
For i = 1 To UBound(sArr, 1)
For J = 1 To UBound(CusName)
If InStr(1, sArr(i, 8), CusName(J), 1) > 0 Then exit for
Next
If J = 1 + UBound(CusName) Then GoTo Next_I
...Em cũng chưa thử nhưng nếu như trường hợp họ chỉ filter ngày tháng hoặc trường khác, không filter cusname( để trống) thì trong trường hợp này code đang thiếu điều kiện if ubound(cusname)>0 phải không bác?Do thêm ";" & nên CusName (0) là giá trị trống bỏ qua. chỉ xét từ CusName (1)Mã:CusName = Split(";" & .Range("B1").Value, ";")
Nhầm, chỉnh lại
Mã:... With Sheets("Filter") CusName = Split(";" & .Range("B1").Value, ";") ... For i = 1 To UBound(sArr, 1) For J = 1 To UBound(CusName) If InStr(1, sArr(i, 8), CusName(J), 1) > 0 Then exit for Next If J = 1 + UBound(CusName) Then GoTo Next_I ...
Mà em thấy cái này tuy đơn giản nhưng hay nè, lúc viết không nghĩ ra được
CusName = Split(";" & .Range("B1").Value, ";")
Lúc đầu em cứ nghĩ cái này nó chỉ bằng 0
Cảm ơn bạn nhiều nhiều ạ, diễn đàn giờ nhiều cao thủ quáa ahiii
Function ConvertCriteria(Field As String, Criteria As String) As String
If Criteria = "*" Then
ConvertCriteria = "TRUE"
Else
ConvertCriteria = "([" & Field & "] LIKE ""%" & Replace(Criteria, ";", "%"" OR [" & Field & "] LIKE ""%") & "%"")"
End If
End Function
Sub ABC()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
Dim s As String, tmp As String
s = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 XML;HDR=YES"";"
cn.Open s
s = "SELECT * FROM [Orders$] WHERE "
s = s & ConvertCriteria("Customer Name", Sheets("Filter").Range("B1"))
s = s & " AND " & ConvertCriteria("Product category", Sheets("Filter").Range("B2"))
s = s & " AND [Order date] >=#" & Sheets("Filter").Range("D1") & "#"
s = s & " AND [Order date] <=#" & Sheets("Filter").Range("D2") & "#"
tmp = Sheets("Filter").Range("E2") & Sheets("Filter").Range("F2")
If tmp = "=0" Then
s = s & " AND (Profit=0 OR Profit is null)"
Else
s = s & " AND Profit" & tmp
End If
rs.Open s, cn
Sheets("Filter").Range("A4:J1000000").ClearContents
Sheets("Filter").Range("A4").CopyFromRecordset rs
rs.Close
cn.Close
End Sub
Kết hợp 2 yêu cầu ở trên, các điều kiện lọc Customer name và Category nằm ở 2 bảng, Oder date from, date to, Profit Compare mode, Profit mỗi thông số nằm ở 1 ô như hình sau, thì Power query đơn giản lắm.
let
DFrom=Excel.CurrentWorkbook(){[Name="DateCondition"]}[Content]{0}[Column1],
DTo=Excel.CurrentWorkbook(){[Name="DateCondition"]}[Content]{1}[Column1],
CompareMode=Excel.CurrentWorkbook(){[Name="ProfitCondition"]}[Content]{0}[Column1],
ComparedProfit=Excel.CurrentWorkbook(){[Name="ProfitCondition"]}[Content]{0}[Column2],
Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
MergedCustomer = Table.NestedJoin(Source, {"Customer Name"}, CusName, {"Customer Name"}, "CusName",
if List.NonNullCount(CusName[Customer Name]) > 0 then JoinKind.Inner else JoinKind.LeftOuter),
MergedCategory = Table.NestedJoin(MergedCustomer, {"Product Category"}, CategoryName, {"Product Category"}, "CategoryName",
if List.NonNullCount(CategoryName[Product Category]) > 0 then JoinKind.Inner else JoinKind.LeftOuter),
DateFilter=Table.SelectRows(MergedCategory, each [Order Date] >= DFrom and [Order Date] <= DTo),
ProfitFilter=Table.SelectRows(DateFilter, each
if CompareMode = ">" then [Profit] > ComparedProfit
else if CompareMode = ">=" then [Profit] >= ComparedProfit
else if CompareMode = "<" then [Profit] < ComparedProfit
else if CompareMode = "<=" then [Profit] <= ComparedProfit
else if CompareMode = "=" then [Profit] = ComparedProfit
else true)
in
ProfitFilterDạ vầng, con cảm ơn chú Mỹ đã chỉ dẫn thêm chon con cách nữa ạ.
Rất tiếc là tôi trích dẫn và trả lời bài của @phuongvq123 theo yêu cầu to hơn, nên chả buồn làm gì
Ngoài vấn đề OT đã đề cập tại bài 46:
www.giaiphapexcel.com
Chú Mỹ nếu có hứng thú thì sử dụng VBA đua tốc độ đi chú, code của chú con đọc dễ hiểu ạ vì code của chú nhiều biến (tham số)
Code của bác hình như chưa đúng yêu cầu đề bài. Điều kiện lọc Customer name không phải tìm chính xác, không chứa họ tên đầy đủ mà chỉ là bộ phận của họ tên đó (ví dụ điều kiện lọc là "a;b" thì giá trị dạng "abc" cũng phù hợp).
let
Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Order ID", Int64.Type}, {"Order Date", type date}, {"Order Quantity", Int64.Type}, {"Sales", type number}, {"Ship Mode", type text}, {"Profit", type number}, {"Unit Price", type number}, {"Customer Name", type text}, {"Customer Segment", type text}, {"Product Category", type text}}),
lstCustomerName=Text.Split(TableFilter[Customer Name]{0},";"),
lstProductCat=Text.Split(TableFilter[Product Category]{0},";"),
CheckCondition = (txt as text, lst as list) =>
if lst{0}="*" then true else
let
lst1=List.Generate(()=> 0, each if _=List.Count(lst) then false else not Text.Contains(txt, lst{_}), each _ +1),
kq=List.Count(lst1)<List.Count(lst)
in
kq,
kq = Table.SelectRows(#"Changed Type",each CheckCondition([Customer Name], lstCustomerName) and CheckCondition([Product Category], lstProductCat) and [Order Date]>=TableFilter[from Order Date]{0} and [Order Date]<=TableFilter[to Order Date]{0} and Expression.Evaluate((if [Profit] is null then "0" else Number.ToText([Profit])) & TableFilter[Profit1]{0} & TableFilter[Profit2]{0}))
in
kqlet
Source = Excel.CurrentWorkbook(){[Name="Table4"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Customer Name", type text}, {"Product Category", type text}, {"from Order Date", type date}, {"to Order Date", type date}, {"Profit1", type text}, {"Profit2", type text}})
in
#"Changed Type"Tôi đã ghi chú rõ rằng "các điều kiện lọc Customer name và Category nằm ở 2 bảng" vì tôi thích dữ liệu dạng chuẩn, chứ không thích kiểu không chuẩn rồi hành xác. Ngoài ra, trong danh mục khách hàng có tình trạng như dưới đây:
Thực chất do mình sơ ý chỗ if profit <>"" ở gần cuối vòng lặp i quên đưa bo=false vào, khi nó sang vòng mới một số trường hợp nó sẽ cho bo=true dẫn đến code sai, bạn thêm bo=false tương tự như các dòng trên
Option Explicit
Sub NTKTNN()
Dim sArr(), dArr(), CusName, ProCat, fDate As Long, tDate As Long, Profit As String, Bo As Boolean
Dim i As Long, J As Long, K As Long
Application.ScreenUpdating = False
With Sheets("Filter")
CusName = Split(";" & .Range("B1").Value, ";")
ProCat = Split(";" & .Range("B2").Value, ";")
fDate = .Range("D1").Value
tDate = .Range("D2").Value
Profit = .Range("E2").Value
End With
With Sheets("Orders")
sArr = .Range("A2:J" & .Cells(.Rows.Count, "A").End(xlUp).Rows).Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr, 1)
For J = 1 To UBound(CusName)
If InStr(1, sArr(i, 8), CusName(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I Else Bo = False
For J = 0 To UBound(ProCat)
If InStr(1, sArr(i, 10), ProCat(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I Else Bo = False
If fDate > 0 And tDate > 0 Then
If sArr(i, 2) >= fDate And sArr(i, 2) <= tDate Then Bo = True
If Bo = False Then GoTo Next_I Else Bo = False
End If
If Profit <> "" Then
If Evaluate(sArr(i, 6) & Profit) Then Bo = True
If Bo = False Then GoTo Next_I Else Bo = False
End If
K = K + 1
For J = 1 To UBound(sArr, 2)
dArr(K, J) = sArr(i, J)
Next
Next_I:
Next
End With
Sheets("Filter").Range("A4:J10000").ClearContents
Sheets("Filter").Range("A4").Resize(UBound(sArr), UBound(sArr, 2)) = dArr
Application.ScreenUpdating = True
End SubSao dArr hầu như luôn luôn < sArr mà lại gán kết quả bằng với kích thước của sArr vậy? thường với kiểu điều kiện lọc này (kiểu kỳ cục) thì chỉ có 3-4 customer, biến k chỉ có giá trị một vài chục mà gán chi tới 1 ngàn. Kết quả không sai nhưng đọc code thấy sao sao ấy.
Cảm ơn thầy đã góp ý, lúc viết xong và gửi lên đây rồi sau đó có lúc em nghĩ tới cái này, xong gửi rồi không sửa, lần sau gửi lại thì chỉ để ý tới lỗi bạn ấy nói thôi. resize(k+1,UBound(sArr, 2)) là đủ rồi mà em thích bự quá thầy nhỉ
Như đã viết trong bài #52, tôi không thích kiểu đặt điều kiện lọc như vậy nên không hứng thú với việc "hành xác" viết code. Ngoài ra tốc độ đối với tôi chỉ có ý nghĩa khi giảm từ 10 giây xuống 1 giây, nếu chỉ giảm từ 1 giây còn 0.8 giây hay 0.5 giây thì là làm vì đam mê. Chưa bao giờ làm vì đua.Chú Mỹ nếu có hứng thú thì sử dụng VBA đua tốc độ đi chú, code của chú con đọc dễ hiểu ạ vì code của chú nhiều biến (tham số)
Bạn ơi vẫn như bài 50 ạ:
Con thấy có chuyện gì sảy ra đâu chú Mỹ, con đang sử dụng ADO bài 45 ạ.
Đọc thật kỹ nhé: "cần tìm Alan Barnes và Christine Abelman", kết quả tình cờ khớp Barnes, nhưng ra thêm Alan Shoneley và ristin lại ra Kargatis.
Bạn sửa lại đoạn sau nha (J=1 thay vì 0 quên lui quên tới
)
Sẽ có khi dư, khi mà tất cả các dòng dữ liệu đều thoả. Thí dụ bỏ trống customer name, bỏ trống category, date from = 1/1/1950, date to = 31/12/2021, Profit > 1 tỷ. Dư 1 dòng và dòng đó lỗi VALUES
Cái này hình như chưa đúng lắm thầy ạ (bỏ qua vấn đề code em còn đang lỗi ở một số ô profit="" không so sánh được nhé). Nếu theo code, tất cả đều thỏa là cứ bỏ trống toàn bộ. Vậy khi resize tăng thêm 1 dòng để gán darr thì dòng cuối là dòng trống chứ sao lại báo lỗi value thầy? ví dụ như darr=1000 dòng 10 cột, mình resize(1001,10) =darr vẫn được mà thầy
Vậy thầy kiểm tra lại giúp em, sao code em để k+1 vậy (điều kiện trên để trống hết), dữ liệu trả về đủ cả mà dòng cuối cùng không bị #N/A vậy ạ? Trường hợp này có đặc biệt gì không thầy
Sau khi thoát vòng lặp thì k chứa số dòng dữ liệu, nếu k=ubound(sarr) thì vùng k+1 sẽ lớn hơn số dòng của mảng dẫn đến lỗi. Cách khắc phục là bạn không nên tìm cách thu gọn code lại dẫn tới khó hiểu, dễ sai, cứ xét if k>0 then resize(k) là được.
Do bạn lấy dữ liệu sArr luôn cả tiêu đề nên số dòng của sArr nhiều hơn dữ liệu 1 dòng. Sau đó dArr lại Redim bằng với sArr
With Sheets("Orders")
sArr = .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Rows).Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))Lúc nãy em hỏi là em đã kiểm tra theo code bài #53 thầy ạ, còn từ A1 thì K+1 là vừa đủ thì em biết. Nhưng cuối cùng kiểm tra kỹ lại nó là ở chỗ này (nhiều khi nhanh nhẩu quá khổ):
sArr = .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Rows).ValueOption Explicit
Sub NTKTNN()
Dim sArr(), dArr(), CusName, ProCat, fDate As Long, tDate As Long, Profit As String, Bo As Boolean
Dim i As Long, J As Long, K As Long
Application.ScreenUpdating = False
With Sheets("Orders")
sArr = .Range("A2:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
With Sheets("Filter")
CusName = Split(";" & .Range("B1").Value, ";")
ProCat = Split(";" & .Range("B2").Value, ";")
fDate = .Range("D1").Value
tDate = .Range("D2").Value
Profit = .Range("E2").Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr, 1)
For J = 1 To UBound(CusName)
If InStr(1, sArr(i, 8), CusName(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I Else Bo = False
For J = 1 To UBound(ProCat)
If InStr(1, sArr(i, 10), ProCat(J), 1) > 0 Then Bo = True: Exit For
Next
If Bo = False Then GoTo Next_I Else Bo = False
If fDate > 0 And tDate > 0 Then
If sArr(i, 2) >= fDate And sArr(i, 2) <= tDate Then Bo = True
If Bo = False Then GoTo Next_I Else Bo = False
End If
If Profit <> "" Then
If Evaluate(sArr(i, 6) * 1 & Profit) Then Bo = True
If Bo = False Then GoTo Next_I Else Bo = False
End If
K = K + 1
For J = 1 To UBound(sArr, 2)
dArr(K, J) = sArr(i, J)
Next
Next_I:
Next
If K Then
.Range("A4:J10000").ClearContents
.Range("A4").Resize(K, UBound(sArr, 2)) = dArr
End If
End With
Application.ScreenUpdating = True
End SubKể cả .Row (không s) nhưng lấy từ A1:J mà làm sao không dư
ô E2 giá trị Profit format cell là "Text"
Sub XYZ()
Dim sArr(), Res()
Dim i&, n&, k&, j&, sRow&, sCol&
Dim Customer, Product, fDate, eDate, Profit, tmp
With Sheets("Orders")
sArr = .Range("A2:J" & .Range("H" & Rows.Count).End(xlUp).Row).Value
End With
sRow = UBound(sArr): sCol = UBound(sArr, 2)
ReDim Res(1 To sRow, 1 To 10)
With Sheets("Filter")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 3 Then .Range("A4:J" & i).ClearContents 'Xoa du lieu
Customer = Split(";" & .Range("B1").Value, ";")
If Customer(1) = "*" Then Customer(1) = ""
Product = Split(";" & .Range("B2").Value, ";")
If Product(1) = "*" Then Product(1) = ""
fDate = .Range("D1").Value: eDate = .Range("D2").Value
If Not (IsDate(fDate) And IsDate(eDate)) Or fDate > eDate Then
MsgBox ("Nhap lai dieu kien ngay thang"): Exit Sub
End If
Profit = .Range("E2").Value
If IsNumeric(Profit) And Profit <> Empty Then Profit = "=" & Profit
End With
For i = 1 To sRow
tmp = sArr(i, 8)
For n = 1 To UBound(Customer)
If InStr(1, tmp, Customer(n), vbTextCompare) > 0 Then Exit For
Next n
If n = UBound(Customer) + 1 Then GoTo KhongThoaDieuKien
tmp = sArr(i, 10)
For n = 1 To UBound(Product)
If InStr(1, tmp, Product(n), vbTextCompare) > 0 Then Exit For
Next n
If n = UBound(Product) + 1 Then GoTo KhongThoaDieuKien
If sArr(i, 2) < fDate Or sArr(i, 2) > eDate Then GoTo KhongThoaDieuKien
If Evaluate(Val(sArr(i, 6)) & Profit) Or Profit = Empty Then
k = k + 1
For j = 1 To 10
Res(k, j) = sArr(i, j)
Next j
End If
KhongThoaDieuKien:
Next i
If k Then Sheets("Filter").Range("A4:J4").Resize(k).Value = Res
End Sub
Điều kiện B1 và B2 là chuỗi đầy đủ hay là sao em?
Xin cảm ơn Bác @HieuCD và Bạn @Nhattanktnn đã luôn quan tâm & giúp đỡ OT, cả 2 code chạy khá nhanh ra kết quả chính xác rồi ạ.
Vậy túm lại là em đã tìm ra đáp án cho mình rồi?
Túm lại là có mấy anh và cả mấy chú chiều chuộng rồi. Anh @Hai Lúa Miền Tây có tham gia hông?
Câu nói hay nhất trong ngày đây rồi chú Mỹ, hú hú hú
Còn nửa câu chưa nói: Trong số chiều chuộng đó không có lão ctCâu nói hay nhất trong ngày đây rồi chú Mỹ, hú hú hú
Chú Mỹ không chiều nhưng cũng có tận mấy bài liền rồi vừa là bài làm theo ý của chú, vừa là các bài chỉ dẫn nữa
Nạp hết vào Recordset rồi lọc dữ liệu. Tuy nhiên nếu lọc 1 lần trên dữ liệu thì em có thể dùng kết quả những bài trên. Còn nếu cứ dùng Recordset đó để lọc nhiều lần thì nên dùng cách anh đề nghị.Dạ vầng đúng rồi anh: PQ,VBA,ADO đều đủ cả rồi anh ạ.
Nếu anh Hai Lúa có thêm cách gì độc đáo & và có hứng thì ... tiếp tục đi anh.
Hic anh Hai Lúa nói vậy OT tiếp thu không khác gì đàn gảy tai trâu anh ơi.
Nạp nó tương tự bài Khai thác và tùy biến thêm, sửa, xuất file và lấy dữ liệu từ Recordset đó em.Hic anh Hai Lúa nói vậy OT tiếp thu không khác gì đàn gảy tai trâu anh ơi.
"Còn nếu cứ dùng Recordset đó để lọc nhiều lần thì nên dùng cách anh đề nghị." nếu có hứng thú anh chỉ dẫn thêm cách này nhé anh.
Lão ấy không chiều chuộng, lão làm đơn giản vì lão biết là cổ thôi.Chú Mỹ không chiều nhưng cũng có tận mấy bài liền rồi vừa là bài làm theo ý của chú, vừa là các bài chỉ dẫn nữa
Public Function ConvertCriteria(Field As String, Criteria As String, sLike As String) As String
If Criteria = "*" Then
ConvertCriteria = "TRUE"
Else
ConvertCriteria = "([" & Field & "] LIKE " & sLike & _
Replace(Criteria, ";", sLike & " OR [" & Field & "] LIKE " & sLike) & sLike & ")"
End If
End Function
Sub Filter_Rst()
Dim Rst As New ADODB.Recordset, sCn As String, SrtSQL As String
Dim wb As Workbook, shtFilter As Worksheet, sLike As String, Lr As Long
Dim Customer As String, Product As String, Profit As String, fDate As Date, eDate As Date
Const sDULIEU As String = "Select * from [Orders$]"
On Error GoTo ErrorProcess
Set wb = ThisWorkbook
Set shtFilter = wb.Worksheets("Filter")
With shtFilter
Lr = .Range("A" & Rows.Count).End(xlUp).Row
If Lr > 3 Then .Range("A4:J" & Lr).ClearContents
Customer = .Range("B1"): Product = .Range("B2")
fDate = .Range("D1"): eDate = .Range("D2")
Profit = .Range("E2")
End With
sLike = "*"
SrtSQL = ConvertCriteria("Customer Name", Customer, sLike)
SrtSQL = SrtSQL & " AND " & ConvertCriteria("Product category", Product, sLike)
If Not (IsDate(fDate) And IsDate(eDate)) Or fDate > eDate Then
MsgBox "Nhap lai dieu kien ngay thang", vbCritical, "Error"
GoTo EndSub
Else
If SrtSQL <> Empty Then
SrtSQL = SrtSQL & " AND ([Order date] >=#" & fDate & "#" & " AND [Order date] <=#" & eDate & "#)"
Else
SrtSQL = " ([Order date] >=#" & fDate & "#" & " And [Order date] <=#" & eDate & "#)"
End If
End If
If Profit <> Empty Then
If Profit = "=0" Then
SrtSQL = SrtSQL & " AND (Profit=0)"
Else
SrtSQL = SrtSQL & " AND Profit" & Profit
End If
End If
Debug.Print SrtSQL
sCn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & wb.FullName
With Rst
.Open sDULIEU, sCn, 1
.Filter = SrtSQL
shtFilter.Range("A4").CopyFromRecordset .DataSource
End With
GoTo EndSub
ErrorProcess:
If Err <> 0 Then
MsgBox Err.Number & "/" & Err.Source & "-->" & Err.Description, vbOKOnly + vbCritical, "Error"
End If
EndSub:
If Not Rst Is Nothing Then
If Rst.State = adStateOpen Then Rst.Close
End If
Set Rst = Nothing
End SubBiết là "cổ" mà vẫn không chiều, lại còn mắng là kiểu đặt điều kiện lọc kỳ cục. Còn làm là làm theo kiểu chuẩn không kỳ cục.Lão ấy không chiều chuộng, lão làm đơn giản vì lão biết là cổ thôi.
Không ổn rồi chú Mỹ xem giúp con câu lệnh bài #81 của con thế nào nếu B1 hoặc B2 có 1 điều kiện thì không sao còn từ 2 điều kiện trở lên là câu truy vấn bị lỗi. Hic
Hàm ConvertCriteria có split chuỗi ra đâu mà 2 với nhiều điều kiệnKhông ổn rồi chú Mỹ xem giúp con câu lệnh bài #81 của con thế nào nếu B1 hoặc B2 có 1 điều kiện thì không sao còn từ 2 điều kiện trở lên là câu truy vấn bị lỗi. Hic
Ủa con vận dụng y chang bài 45 của bạn @Hau151978 mà Chú, con nghĩ là có thể là có thể do cú pháp áp dụng trong Recordset với nhiều điều kiện trong một trường mà con làm sang bị sai ở đâu đó ấy ạ. Hic con tưởng ngon ăn, giờ test thử mà thấy nhiều lỗi quá chú ạ, ví dụ lỗi nếu B1 không có gì mà B2 có cũng không được.. hic
Cái sai chỉ nằm trong phạm vi cái hàm ConvertCriteria thôi.
Cảm ơn Bạn Hau151978 đã góp ý.
If Criteria = "*" Or Criteria = "" Then
ConvertCriteria = "TRUE"Nếu B1 và/ hoặc B2 rỗng thì làm sao lỗi được, câu điều kiện lọc SQL là
Vâng đúng là con chưa test thật nên mới nghĩ là có thể, nhưng đúng là kiểu bắt lỗi này như chú Mỹ giải thích con thấy đơn giản và hiệu quả thật thay vì phải sử dụng nhiểu hàm if, cảm ơn chú Mỹ.
Theo mình đoán thì sau chuỗi sau LIKE phải để trong cặp dấu nháy, còn tại sao lệnh trên chạy được thì không rõ, chắc do may mắn, mình chỉ đoán thôi chứ toàn gán toàn bộ recordset xuống sheet, không làm kiểu này bao giờ.
Xin chào bạn @Hau151978 ,
trong hàm ConvertCriteria OT cũng đã thay toàn bộ "%" thành "*" rồi:
nhưng vẫn không được ạ.
www.giaiphapexcel.com
Dạ OT gửi Bạn file ạ, vẫn là file từ bài 28 (nhưng bạn có góp ý E2,F2 nên gộp chung lại thành 1 nên OT đã gộp ạ)
Em không biết, máy em chạy bình thường mà, chỉ có 4 dòng thôi. File bài 96.
Quay lại xài mảng, hoặc Power query cho chắc cú, với điều kiện lọc chuẩn. Chiều chuộng hoài cho mệt
Nếu dùng ADO copy toàn bộ recordset thì câu lệnh SQL cũng đơn giản mà bác, em không hiểu sao máy bác lại ra vậy, chắc chạy nhiều bị loạn. Riêng Recordset.Filter mới có quy định chặt chẽ, không như mệnh đề WHERE.Quay lại xài mảng, hoặc Power query cho chắc cú, với điều kiện lọc chuẩn. Chiều chuộng hoài cho mệt
