Nhờ viết VBA lọc dữ liệu nhiều điều kiện (5 người xem)

[SA_DQ]

(1) Bạn nên đưa toàn bộ macro lên, đó là tạo điều kiện cho người có nhã í giúp mình;

(2) Sao bạn không nhờ ngay tác giả dịch hộ cho; Không ai có thể dịch tốt hơn bạn í đâu.

(3) Có thể điều này bạn chưa chú í:

(3.1) Nên thẳng cột các nhóm lệnh để tiện trong quan sát & vì vậy tránh sai sót khi viết cũng như khi diễn dịch.
Bạn xem cách sau đây có dễ nhìn hơn không:

Option Explicit
Sub XXX()
' ' ' ' '  '
3 For i = 1 To UBound(data)
    If data(i, 3) > 7 Then
5        If Not dic.exists(data(i, 1)) Then
            n = UBound(ketqua, 2)
7            k = 1
            dic.Add data(i, 1), n & "#" & k
9            ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
            For j = 1 To 3
11                ketqua(k, n + j - 1) = data(i, j)
            Next
13        Else
            rw = Split(dic.Item(data(i, 1)), "#")(1)
15            col = Split(dic.Item(data(i, 1)), "#")(0)
            rw = rw + 1
17            dic.Item(data(i, 1)) = col & "#" & rw
            If rw > max_rw Then max_rw = rw
19            For j = 1 To 3
                ketqua(rw, j + col - 1) = data(i, j)
21            Next
        End If
23        ngay = data(i, 1)
    End If
25 Next
' . . . . . '
End Sub

(3.2) Bạn biết không, VBA cho ta đánh số cho những dòng lệnh
Điều này thực ra giúp cho người viết Code fát hiện nhanh dòng lệnh đang sai sót nhờ hàm của nó; Đó là hàm Erl().
Còn khi bạn nhờ dịch sẽ tiện cho người dịch & người được dịch trao đổi cho nhau thông qua các chỉ số dòng lệnh ta đã ấn định (Xem trên)

Vài lời, những mong giúp được bạn ít nhiều!

 

[gianghoxaotra]

(1) Bạn nên đưa toàn bộ macro lên, đó là tạo điều kiện cho người có nhã í giúp mình;

(2) Sao bạn không nhờ ngay tác giả dịch hộ cho; Không ai có thể dịch tốt hơn bạn í đâu.

(3) Có thể điều này bạn chưa chú í:

(3.1) Nên thẳng cột các nhóm lệnh để tiện trong quan sát & vì vậy tránh sai sót khi viết cũng như khi diễn dịch.
Bạn xem cách sau đây có dễ nhìn hơn không:

(3.2) Bạn biết không, VBA cho ta đánh số cho những dòng lệnh
Điều này thực ra giúp cho người viết Code fát hiện nhanh dòng lệnh đang sai sót nhờ hàm của nó; Đó là hàm Erl().
Còn khi bạn nhờ dịch sẽ tiện cho người dịch & người được dịch trao đổi cho nhau thông qua các chỉ số dòng lệnh ta đã ấn định (Xem trên)

Vài lời, những mong giúp được bạn ít nhiều!

Option Explicit
Sub Loc_DL()
Dim data, ketqua As Variant, i, j, k, n, ngay, col, max_rw, rw As Long, dic As Object
ReDim ketqua(1 To 60000, 1 To 1)
With Sheets("Data")
data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
Set dic = CreateObject("scripting.dictionary")
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
If Not dic.exists(data(i, 1)) Then
n = UBound(ketqua, 2)
k = 1
dic.Add data(i, 1), n & "#" & k
ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
For j = 1 To 3
ketqua(k, n + j - 1) = data(i, j)
Next
Else
rw = Split(dic.Item(data(i, 1)), "#")(1)
col = Split(dic.Item(data(i, 1)), "#")(0)
rw = rw + 1
dic.Item(data(i, 1)) = col & "#" & rw
If rw > max_rw Then max_rw = rw
For j = 1 To 3
ketqua(rw, j + col - 1) = data(i, j)
Next
End If
ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(max_rw, n + 3) = ketqua
End With
End Sub

Đây là code đầy đủ của một bạn viết dùm mình ở trên đó bạn. Nhờ bạn giúp dùm. Cảm ơn nhé.

 

[comet_1701]

Option Explicit
Sub Loc_DL()
Dim data, ketqua As Variant, i, j, k, n, ngay, col, max_rw, rw As Long, dic As Object
ReDim ketqua(1 To 60000, 1 To 1)
With Sheets("Data")
data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
Set dic = CreateObject("scripting.dictionary")
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
If Not dic.exists(data(i, 1)) Then
n = UBound(ketqua, 2)
k = 1
dic.Add data(i, 1), n & "#" & k
ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
For j = 1 To 3
ketqua(k, n + j - 1) = data(i, j)
Next
Else
rw = Split(dic.Item(data(i, 1)), "#")(1)
col = Split(dic.Item(data(i, 1)), "#")(0)
rw = rw + 1
dic.Item(data(i, 1)) = col & "#" & rw
If rw > max_rw Then max_rw = rw
For j = 1 To 3
ketqua(rw, j + col - 1) = data(i, j)
Next
End If
ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(max_rw, n + 3) = ketqua
End With
End Sub

Đây là code đầy đủ của một bạn viết dùm mình ở trên đó bạn. Nhờ bạn giúp dùm. Cảm ơn nhé.

n & "#" & k

Cái này là item, chắc bạn biết.
Ví dụ Arr=Array(1,2) thì Arr(0)=1, Arr(1)=2 (option Base 0)

rw = Split(dic.Item(data(i, 1)), "#")(1) =k
col = Split(dic.Item(data(i, 1)), "#")(0) =n

Kết quả trả về bao gồm nhiều cột, mỗi cột lại có số dòng là khác nhau nên phải xác định dòng lớn nhất

If rw > max_rw Then max_rw = rw

Mỗi người một đoạn cho đỡ ngại, của anh Let's Gâu Gâu, đợi anh ý lên giải thích nốt nhé. Chúc bạn thành công.

 

[gianghoxaotra]

Sub FilterData()
Dim Table As Object

Table = Range(Sheets("Data").[A1], Sheets("Data").[C10000].End(xlUp))

'Range("G2:K1000").Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Clear

Sheets("Data").Range("Table").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets("Data").Range("D1:F2"), CopyToRange:=Sheets("Data").Range("G2"), Unique:=True


Columns.AutoFit
Range("G2").Select

End Sub


Mình viết đoạn code này mà sao chạy nó báo lỗi. Mọi người help với. Cảm ơn.

 

[comet_1701]

Sub FilterData()
Dim Table As Object

Table = Range(Sheets("Data").[A1], Sheets("Data").[C10000].End(xlUp))

'Range("G2:K1000").Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Clear

Sheets("Data").Range("Table").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets("Data").Range("D1:F2"), CopyToRange:=Sheets("Data").Range("G2"), Unique:=True


Columns.AutoFit
Range("G2").Select

End Sub


Mình viết đoạn code này mà sao chạy nó báo lỗi. Mọi người help với. Cảm ơn.

Sub FilterData()
Dim Table As Object


Set Table = Range(Sheets("Data").[A1], Sheets("Data").[C10000].End(xlUp))


'Range("G2:K1000").Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Clear


Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets("Data").Range("D1:F2"), CopyToRange:=Sheets("Data").Range("G2"), Unique:=True




Columns.AutoFit
Range("G2").Select


End Sub

Bạn chả buồn gửi file đính kèm lên. Hỏi xuông thế này, các thành viên họ ngại test lắm. Bạn thử , nếu chạy được thì tốt không thì thôi vậy. Mà cái này không liên quan đến topic của bạn, bạn nên mở một topic mới nhé.

 

[huy vu]

Sub FilterData()
Dim Table As Object

Table = Range(Sheets("Data").[A1], Sheets("Data").[C10000].End(xlUp))

'Range("G2:K1000").Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Clear

Sheets("Data").Range("Table").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets("Data").Range("D1:F2"), CopyToRange:=Sheets("Data").Range("G2"), Unique:=True


Columns.AutoFit
Range("G2").Select

End Sub


Mình viết đoạn code này mà sao chạy nó báo lỗi. Mọi người help với. Cảm ơn.

Sao table lại khai báo biến object? Phải là 1 range chứ.
sao không AF trực tiếp luôn, khai báo biến làm chi.
Tốt nhất là bạn gửi file lên xem sao?

 

[andredat]

Chào các AC,
Mình không giỏi code nhưng thấy đề tài này hay hay nên xin góp một ví dụ nhỏ. Mong các bạn góp ý. Thanks!