Code lọc dữ liệu
- Thread starter 790312
- Ngày gửi
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Thử dùng code này xem:
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRng As Range
On Error Resume Next
If Target.Address = "$G$15" Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet1.Cells.Find(Left(Target, 2), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
End If
End If
End Sub
Upvote
0
Cảm ơn bác rất nhiều,bác ở đâu vậy?e có thể gặp bác uống cafe được không?Bác giúp sửa giùm e code trong file e gửi đinh kèm với.Thanks
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Chỉ sửa có mỗi 1 dòng, cái này:
If Target.Address = "$G$15" Then
thành cái này:
If Not Intersect(Range("D15:G15"), Target) Is Nothing Then
Vậy thôi
Upvote
0
Trong file này thì lọc F1,F2,F3,F4 từ sheet1.Vậy e có thêm F5,F6,F7 lọc từ sheet3 thì làm sao vậy bác.Cảm ơn bác trước.
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Thì thêm thế này:
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRng As Range
On Error Resume Next
If Not Intersect(Range("D15:G15"), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet1.Cells.Find(Left(Target, 2), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
End If
ElseIf Not Intersect(Range("H15:J15"), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet3.Cells.Find(Left(Target, 2), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
End If
End If
End Sub
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Cụ thể thế nào bạn cho file lên xem thử nhé (mình chưa hình dung ra)
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Thì lại sửa tiếp ---> Với các cell không liên tục ta dùng Union nhé
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRng As Range
On Error Resume Next
If Not Intersect(Union([D15], [F15], [H15], [J15]), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet1.Cells.Find(Left(Target, 3), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
End If
ElseIf Not Intersect(Union([E15], [G15], [I15], [K15]), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet3.Cells.Find(Left(Target, 3), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
End If
End If
End SubThế thôi
Upvote
0
huyentt510
Thành viên hoạt động
- Tham gia
- 12/10/10
- Bài viết
- 124
- Được thích
- 4
cho mình hỏi xem trong file đính kèm có sử dụng công thức nhưng không thể lọc hết các điều kiện: {nếu D9>=49.5 thì "P", nếu D9<49.5 thì "T", nếu D9=I thì "I"} . trong sheet2 mình đã có sử dụng công thức các bạn chỉ dẫn nhưng nếu lọc được "P' và "T" thì không được "I'" nhưng nếu được "T" và "I" thì không được "P".... . Cho mình hỏi luôn COLUMN()-8,0 nghĩa là gì nhỉ? tại sao lại -8? và công thức trong sheet 2 lại không thể lọc hết được đúng yêu cầu trên?
Upvote
0
Cảm ơn bác nhiều,nhưng khi bên sheet đầu tiên nếu trong các ô có công thức thì nó lọc qua cả công thức đưa qua làm sai kết quả,bác chỉnh giùm e sao cho chỉ lọc qua kết quả thôi.E có gửi file đính kèm ở dưới.
Lần chỉnh sửa cuối:
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Sửa đoạn:
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
Thành:
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 3
Sửa đoạn:
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
Thành:
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 3
Upvote
0
Cảm ơn sự giúp đỡ nhiệt tình của bác,bác cho em hỏi thêm 1 câu nữa,sau khi sửa dòng lệnh này thì đã thực hiện công việc đầy đủ nhưng khi lọc thì ngay vị trí cần lọc qua nó bị đổi font và mất định dạng chính giữa theo định dạng ban đầu.Chúc bác ngày càng nhiều sức khoẻ.
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,952
Vì chỉ Paste Values nên đương nhiên nó chỉ lấy Values, không lấy Formats
Muốn lấy thêm định dạng, phải Paste lần nữa như sau:
Thay:
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
Thành:
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 3
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 4
Thay:
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy Target.Offset(1)
Thành:
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 3
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy: Target.Offset(1).PasteSpecial 4
===> Có nghĩa là 1 dòng code củ thay bằng 2 dòng code mới, dòng trên lấy giá trị, dòng dưới lấy định dạng
Hoặc có thể trình bày lại
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRng As Range
On Error Resume Next
If Not Intersect(Union([D15], [F15], [H15], [J15]), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet1.Cells.Find(Left(Target, 3), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet1.Range(fRng.Offset(1), fRng.End(xlDown)).Copy
Target.Offset(1).PasteSpecial 3
Target.Offset(1).PasteSpecial 4
End If
Application.CutCopyMode = 0
ElseIf Not Intersect(Union([E15], [G15], [I15], [K15]), Target) Is Nothing Then
Range(Target.Offset(1), Target.End(xlDown)).Clear
Set fRng = Sheet3.Cells.Find(Left(Target, 3), , xlValues, xlPart)
If Not fRng Is Nothing Then
Sheet3.Range(fRng.Offset(1), fRng.End(xlDown)).Copy
Target.Offset(1).PasteSpecial 3
Target.Offset(1).PasteSpecial 4
End If
Application.CutCopyMode = 0
End If
End Sub
Lần chỉnh sửa cuối:
Upvote
0
Bài viết mới nhất
- Question
- Question
- Đã giải quyết
- Question
