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

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
G

gianghoxaotra

Thành viên chính thức
Tham gia
6/2/13
Bài viết
53
Được thích
1
Mình có file dữ liệu mẫu, cần lọc dữ liệu từ Sheet Data sang Sheet KQ.
Mình có ghi hướng dẫn trong file.
Nhờ các cao thủ giúp viết dùm code VBA để chạy tự động cho nhanh.
Cảm ơn.
 

File đính kèm

gianghoxaotra đã viết:
Mình có file dữ liệu mẫu, cần lọc dữ liệu từ Sheet Data sang Sheet KQ.
Mình có ghi hướng dẫn trong file.
Nhờ các cao thủ giúp viết dùm code VBA để chạy tự động cho nhanh.
Cảm ơn.
Nhấp chuột vào đây để mở rộng...
Ở ô J6, bạn muốn lọc những Loại >= 7 ???

Mã: 
Sub LocDL()
Dim Data(), i&, KQ(), k&
Data = Range(Sheet1.[A2], Sheet1.[A5000].End(3)).Resize(, 3)
ReDim KQ(1 To UBound(Data), 1 To 3)
For i = 1 To UBound(Data)
    If Data(i, 3) >= 7 Then
        k = k + 1
        KQ(k, 1) = Data(i, 1)
        KQ(k, 2) = Data(i, 2)
        KQ(k, 3) = Data(i, 3)
    End If
Next
Sheet2.[J6:L5000].ClearContents
Sheet2.[J6].Resize(k, 3) = KQ
end sub
 
Chỉnh sửa lần cuối bởi điều hành viên:
Bài này có thể dùng Advance Filter. Cách làm:
1. Thiết lập vùng điều kiện
2. Click record macro
3. Thao tác advance filter.
4. Stop record macro.
5. Mở cửa sổ vba có đoạn code.
Đây là cách tôi từng học, chúc bạn thành công.
 
Huy Vũ đã viết:
Ở ô J6, bạn muốn lọc những Loại >= 7 ???

Mã: 
Sub LocDL()
Dim Data(), i&, KQ(), k&
Data = Range(Sheet1.[A2], Sheet1.[A5000].End(3)).Resize(, 3)
ReDim KQ(1 To UBound(Data), 1 To 3)
For i = 1 To UBound(Data)
    If Data(i, 3) >= 7 Then
        k = k + 1
        KQ(k, 1) = Data(i, 1)
        KQ(k, 2) = Data(i, 2)
        KQ(k, 3) = Data(i, 3)
    End If
Next
Sheet2.[J6:L5000].ClearContents
Sheet2.[J6].Resize(k, 3) = KQ
Nhấp chuột vào đây để mở rộng...
Không thử nhưng biết chắc code trên không chạy được. ( Chắc là do post bài không để ý). Hehe
 
Huy Vũ đã viết:
Ở ô J6, bạn muốn lọc những Loại >= 7 ???

Mã: 
Sub LocDL()
Dim Data(), i&, KQ(), k&
Data = Range(Sheet1.[A2], Sheet1.[A5000].End(3)).Resize(, 3)
ReDim KQ(1 To UBound(Data), 1 To 3)
For i = 1 To UBound(Data)
    If Data(i, 3) >= 7 Then
        k = k + 1
        KQ(k, 1) = Data(i, 1)
        KQ(k, 2) = Data(i, 2)
        KQ(k, 3) = Data(i, 3)
    End If
Next
Sheet2.[J6:L5000].ClearContents
Sheet2.[J6].Resize(k, 3) = KQ
end sub
Nhấp chuột vào đây để mở rộng...

Code này chạy chưa giống ý mình muốn bạn ơi.
Ý mình là bên sheet Data,, cột A có 3 ngày được lập lại nhiều lần với trên cùng một cột tương ứng với giá trị tại cột B và C, mình muốn chuyển lọc dữ liệu qua sheet KQ, tách ra từng ngày riêng biệt được bố cục như file mẫu mình đưa lên.
Suy rộng ra, nếu cột A có nhiều ngày thì nó sẽ tự động tách ra nhiều ngày như bố cục mình đưa lên luốn.
Lưu ý là lọc theo điều kiện Loại >7 nữa nhé.
Cảm ơn bạn.
 
gianghoxaotra đã viết:
Code này chạy chưa giống ý mình muốn bạn ơi.
Ý mình là bên sheet Data,, cột A có 3 ngày được lập lại nhiều lần với trên cùng một cột tương ứng với giá trị tại cột B và C, mình muốn chuyển lọc dữ liệu qua sheet KQ, tách ra từng ngày riêng biệt được bố cục như file mẫu mình đưa lên.
Suy rộng ra, nếu cột A có nhiều ngày thì nó sẽ tự động tách ra nhiều ngày như bố cục mình đưa lên luốn.
Lưu ý là lọc theo điều kiện Loại >7 nữa nhé.
Cảm ơn bạn.
Nhấp chuột vào đây để mở rộng...
Có lẽ tôi chưa hiểu ý bạn. Đọc bài này cũng chư hiểu phải ra kq thế nào +-+-+-+
 
gianghoxaotra đã viết:
Mình gửi lại file, bạn xem sẽ dễ hiểu hơn.
Nhấp chuột vào đây để mở rộng...

làm theo yêu cầu bài #1, chưa đọc bài này...hihihiih
Mã: 
Sub hehe()
Dim data, ketqua As Variant, i, j, k, n, ngay, col As Long
ReDim ketqua(1 To 60000, 1 To 3)
With Sheets("Data")
    data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
    If data(i, 1) <> ngay Then
        n = UBound(ketqua, 2)
        ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
        k = 1
        For j = 1 To 3
            ketqua(k, n + j) = data(i, j)
        Next
    Else
        k = k + 1
        If n Then col = n
        For j = 1 To 3
            ketqua(k, j + col) = data(i, j)
        Next
    End If
    ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(k, n + 3) = ketqua
End With
End Sub
========
à quên, xóa cái dòng cuối "tiếp theo......"
cột A phải có định dạng số (date), dạng text báo lổi
 
Let'GâuGâu đã viết:
làm theo yêu cầu bài #1, chưa đọc bài này...hihihiih
Mã: 
Sub hehe()
Dim data, ketqua As Variant, i, j, k, n, ngay, col As Long
ReDim ketqua(1 To 60000, 1 To 3)
With Sheets("Data")
    data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
    If data(i, 1) <> ngay Then
        n = UBound(ketqua, 2)
        ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
        k = 1
        For j = 1 To 3
            ketqua(k, n + j) = data(i, j)
        Next
    Else
        k = k + 1
        If n Then col = n
        For j = 1 To 3
            ketqua(k, j + col) = data(i, j)
        Next
    End If
    ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(k, n + 3) = ketqua
End With
End Sub
========
à quên, xóa cái dòng cuối "tiếp theo......"
cột A phải có định dạng số (date), dạng text báo lổi
Nhấp chuột vào đây để mở rộng...


Nó chạy được nhưng khi giá trị ngày cuối cùng ít dòng thì nó bị sai bạn ơi, lọc ko hết. Bạn xem lại giúp mình. Cảm ơn
 

File đính kèm

gianghoxaotra đã viết:
Nó chạy được nhưng khi giá trị ngày cuối cùng ít dòng thì nó bị sai bạn ơi, lọc ko hết. Bạn xem lại giúp mình. Cảm ơn
Nhấp chuột vào đây để mở rộng...

quên, k nó bị reset lại
Mã: 
Sub hehe()
Dim data, ketqua As Variant, i, j, k, n, ngay, col, maxK As Long
ReDim ketqua(1 To 60000, 1 To 3)
With Sheets("Data")
    data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
    If data(i, 1) <> ngay Then
        n = UBound(ketqua, 2)
        ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
        k = 1
        For j = 1 To 3
            ketqua(k, n + j) = data(i, j)
        Next
    Else
        k = k + 1
        If k > maxK Then maxK = k
        If n Then col = n
        For j = 1 To 3
            ketqua(k, j + col) = data(i, j)
        Next
    End If
    ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(maxK, n + 3) = ketqua
End With
End Sub
 
Let'GâuGâu đã viết:
quên, k nó bị reset lại
Mã: 
Sub hehe()
Dim data, ketqua As Variant, i, j, k, n, ngay, col, maxK As Long
ReDim ketqua(1 To 60000, 1 To 3)
With Sheets("Data")
    data = .Range(.[a2], .[a2].End(4)).Resize(, 3).Value
End With
ngay = data(1, 1)

For i = 1 To UBound(data)
If data(i, 3) > 7 Then
    If data(i, 1) <> ngay Then
        n = UBound(ketqua, 2)
        ReDim Preserve ketqua(1 To 60000, 1 To n + 3)
        k = 1
        For j = 1 To 3
            ketqua(k, n + j) = data(i, j)
        Next
    Else
        k = k + 1
        If k > maxK Then maxK = k
        If n Then col = n
        For j = 1 To 3
            ketqua(k, j + col) = data(i, j)
        Next
    End If
    ngay = data(i, 1)
End If
Next
With Sheet2
.[A6:XFD60000].ClearContents
.[A6].Resize(maxK, n + 3) = ketqua
End With
End Sub
Nhấp chuột vào đây để mở rộng...



Gần đúng rồi bạn ơi, nhưng vẫn còn một lỗi nữa là nếu mình cho cột A (ngày) chạy xem kẽ thì nó lọc ko được hết.
Mình gửi file lên bạn coi dùm nhé. Mình có tô vàng ở sheet Data. Cảm ơn.
 

File đính kèm

Lần chỉnh sửa cuối:
gianghoxaotra đã viết:
Gần đúng rồi bạn ơi, nhưng vẫn còn một lỗi nữa là nếu mình cho cột A (ngày) chạy xem kẽ thì nó lọc ko được hết.
Mình gửi file lên bạn coi dùm nhé. Mình có tô vàng ở sheet Data. Cảm ơn.
Nhấp chuột vào đây để mở rộng...

giải thuật nó sẻ khác hoàn toàn,
cái này chắc phải xài dictionary.
=============
kiểm tra thử nha, còn nếu ko đúng thì, xài lại code cũ, chỉ cần sort lại theo cột A là được
Mã: 
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
 
Lần chỉnh sửa cuối:
Let'GâuGâu đã viết:
giải thuật nó sẻ khác hoàn toàn,
cái này chắc phải xài dictionary.
=============
kiểm tra thử nha, còn nếu ko đúng thì, xài lại code cũ, chỉ cần sort lại theo cột A là được
Mã: 
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
Nhấp chuột vào đây để mở rộng...



Mình thấy code ok rồi đó bạn. Cảm ơn nhiều nhé.
Hic, thấy mọi người viết VBA hay quá mà cũng đang nghiên cứu, học lỏm mà viết hoài chưa được. Anh em nào có biết chỗ nào ở SG dạy viết VBA này ko? hay có tài liệu nào hay chỉ giúp mình với. Cảm ơn nhiều.
 
gianghoxaotra đã viết:
Mình thấy code ok rồi đó bạn. Cảm ơn nhiều nhé.
Hic, thấy mọi người viết VBA hay quá mà cũng đang nghiên cứu, học lỏm mà viết hoài chưa được. Anh em nào có biết chỗ nào ở SG dạy viết VBA này ko? hay có tài liệu nào hay chỉ giúp mình với. Cảm ơn nhiều.
Nhấp chuột vào đây để mở rộng...
ở SG thì ngay ổ rồi. Liên hệ thầy Tuân (bluesofts) có dạy đấy
còn sách thì đây
 
Ở SG thì liên hệ Chị Mộng Tiền __--__//////@#!^%//**/)*&^))*&^)+-+-+-+
 
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

Có ai có thể giải thích giúp mình đoạn code sau đây ko? mình đọc mà ko hiểu lắm. Xin cảm ơn.
 
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

G
Tách công thức ra khỏi chuỗi và tính kết quả? (1 người xem)
2
Trả lời
22
Đọc
2K
gobi
gobi
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
110
VetMini
V
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (1 người xem)
Trả lời
1
Đọc
42
Hoàng Tuấn 868
H
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
3
Đọc
148
Hoàng Tuấn 868
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
346
Đọc
31K
Vandat1607
V
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
15
Đọc
252
Hoangkhang01213
Hoangkhang01213
M
Xin giúp đỡ làm công thức điều kiện
Trả lời
2
Đọc
132
Hoangkhang01213
Hoangkhang01213
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
181
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
300
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
171
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
22
Đọc
578
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy) (2 người xem)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
149
lamvu0677
L
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
811
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA (1 người xem)
Trả lời
6
Đọc
246
Hoàng Tuấn 868
H
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
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom