[HELP] Trích lọc dữ liệu có nhiều điều kiện (1 người xem)

[Tomtep]

Em đang làm cái bảng theo dõi hồ sơ tài liệu của dự án. Em muốn nhờ các bác viết giúp cái code vba để trích dữ liệu từ sheet "Theo doi ho so" đưa sang sheet "Tra cuu ho so" theo 3 điều kiện (điều kiện nào để trống thì không tìm theo điều kiện đó):
1. Văn bản từ ngày A đến ngày B
2. Loại văn bản (có danh sách để chọn)
3. Tìm kiếm theo từ khóa.
Sau khi nhập xong các điều kiện trên thì bấm nút TÌM KIẾM sẽ liệt kê ra các dữ liệu thỏa mãn điều kiện như trên.
Em gửi kèm cái file theo dõi hồ sơ nhờ các bác chỉ giúp em với.
Em xin cảm ơn nhiều
Thân mến

 

[HieuCD]

Sửa gần đúng rồi nhưng sao được chỗ này lại mất chỗ kia thế? Lookin:=xlValues đâu rồi?
Dùng Find Method, bạn ghi càng rõ ràng nó chạy càng chính xác (nếu không sẽ có lúc nó tào lao)
Chỗ màu đỏ tôi nghĩ nên vầy:

Set c = .Find([COLOR=#ff0000]"*" & Sheets(1).Range("C4") & "*"[/COLOR], , xlValues, [COLOR=#ff0000]xlWhole[/COLOR])

(tìm chính xác có kết hợp với ký tự đại diện. Mục đích khi xóa C4 thì ta sẽ tìm "*", tức là tìm tất cả)
Với code sửa lại thì chỗ màu xanh có thể xóa đi
-----------------
Thêm chút góp ý nữa chắc không thừa: KHAI BÁO BIẾN ĐẦY ĐỦ

Bạn xem giúp code đã chỉnh lại, và góp ý thêm, cám ơn

Sub GPE()
Dim i As Long, j As Integer, iRow As Long, Arr(), k As Long
Dim Ngay1 As Date, Ngay2 As Date, LoaiVB As String, c As Range
Application.ScreenUpdating = False
iRow = Sheets(2).Range("B5").End(xlDown).Row
ReDim Arr(1 To iRow, 1 To 11)
Ngay1 = Sheets(1).Range("C2"):   Ngay2 = Sheets(1).Range("F2")
LoaiVB = Sheets(1).Range("C3")
With Worksheets(2).Range("b4:b" & iRow)
    Set c = .Find("*" & Sheets(1).Range("C4") & "*", , xlValues, xlWhole, , , False)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            If Sheets(2).Cells(c.Row, 4) = LoaiVB Or Sheets(1).Range("w3") = LoaiVB Then
                If Sheets(2).Cells(c.Row, 7) >= Ngay1 And Sheets(2).Cells(c.Row, 7) <= Ngay2 Then
                    k = k + 1: Arr(k, 1) = k
                    For j = 2 To 11
                        Arr(k, j) = Sheets(2).Cells(c.Row, j)
                    Next
                End If
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Sheets(1).Range("A8:K" & Sheets(1).Range("B65500").End(xlUp).Row + 2).Clear
If k > 0 Then
    Sheets(1).Range("A8").Resize(k, 11) = Arr
    Sheets(2).Range("A5:K5").Copy
    Sheets(1).Range("A8").Resize(k, 11).Select
    Selection.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    Sheets(1).Range("A8").Select
End If
Set c = Nothing:    Erase Arr
Application.ScreenUpdating = True
End Sub

 

[HieuCD]

Code chạy tốt rồi bạn HieuCd ơi, nhờ bạn chỉnh code thêm để tự động đóng khung (thêm nét kẻ đậm bên dưới ô kết quả cuối cùng để tiện cho in ấn báo cáo) và tự động điều chỉnh chiều cao dòng cho phù hợp với nội dung nữa (vì nhiều kết quả liệt kê ra không thấy hết nội dung cho nội dung dài) là đẹp.
TKS
(Xem hình đính kèm chỗ mình bôi vàng)

bạn sửa lại đoạn cuối của code phần màu đỏ

Sub GPE()
Dim i As Long, j As Integer, iRow As Long, Arr(), k As Long
Dim Ngay1 As Date, Ngay2 As Date, LoaiVB As String, c As Range
Application.ScreenUpdating = False
iRow = Sheets(2).Range("B5").End(xlDown).Row
ReDim Arr(1 To iRow, 1 To 11)
Ngay1 = Sheets(1).Range("C2"):   Ngay2 = Sheets(1).Range("F2")
LoaiVB = Sheets(1).Range("C3")
With Worksheets(2).Range("b4:b" & iRow)
    Set c = .Find("*" & Sheets(1).Range("C4") & "*", , xlValues, xlWhole, , , False)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            If Sheets(2).Cells(c.Row, 4) = LoaiVB Or Sheets(1).Range("w3") = LoaiVB Then
                If Sheets(2).Cells(c.Row, 7) >= Ngay1 And Sheets(2).Cells(c.Row, 7) <= Ngay2 Then
                    k = k + 1: Arr(k, 1) = k
                    For j = 2 To 11
                        Arr(k, j) = Sheets(2).Cells(c.Row, j)
                    Next
                End If
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Sheets(1).Range("A8:K" & Sheets(1).Range("B65500").End(xlUp).Row + 2).Clear
[COLOR=#ff0000]If k > 0 Then[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Resize(k, 11) = Arr[/COLOR]
[COLOR=#ff0000]    Sheets(2).Range("A5:K5").Copy[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Resize(k, 11).Select[/COLOR]
[COLOR=#ff0000]    Selection.PasteSpecial Paste:=xlPasteFormats[/COLOR]
[COLOR=#ff0000]    Application.CutCopyMode = False[/COLOR]
[COLOR=#ff0000]    Selection.EntireRow.AutoFit[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeLeft).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeTop).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeBottom).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeRight).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Select[/COLOR]
[COLOR=#ff0000]End If[/COLOR]
Set c = Nothing:    Erase Arr
Application.ScreenUpdating = True
End Sub

 

[Tomtep]

bạn sửa lại đoạn cuối của code phần màu đỏ

Sub GPE()
Dim i As Long, j As Integer, iRow As Long, Arr(), k As Long
Dim Ngay1 As Date, Ngay2 As Date, LoaiVB As String, c As Range
Application.ScreenUpdating = False
iRow = Sheets(2).Range("B5").End(xlDown).Row
ReDim Arr(1 To iRow, 1 To 11)
Ngay1 = Sheets(1).Range("C2"):   Ngay2 = Sheets(1).Range("F2")
LoaiVB = Sheets(1).Range("C3")
With Worksheets(2).Range("b4:b" & iRow)
    Set c = .Find("*" & Sheets(1).Range("C4") & "*", , xlValues, xlWhole, , , False)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            If Sheets(2).Cells(c.Row, 4) = LoaiVB Or Sheets(1).Range("w3") = LoaiVB Then
                If Sheets(2).Cells(c.Row, 7) >= Ngay1 And Sheets(2).Cells(c.Row, 7) <= Ngay2 Then
                    k = k + 1: Arr(k, 1) = k
                    For j = 2 To 11
                        Arr(k, j) = Sheets(2).Cells(c.Row, j)
                    Next
                End If
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Sheets(1).Range("A8:K" & Sheets(1).Range("B65500").End(xlUp).Row + 2).Clear
[COLOR=#ff0000]If k > 0 Then[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Resize(k, 11) = Arr[/COLOR]
[COLOR=#ff0000]    Sheets(2).Range("A5:K5").Copy[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Resize(k, 11).Select[/COLOR]
[COLOR=#ff0000]    Selection.PasteSpecial Paste:=xlPasteFormats[/COLOR]
[COLOR=#ff0000]    Application.CutCopyMode = False[/COLOR]
[COLOR=#ff0000]    Selection.EntireRow.AutoFit[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeLeft).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeTop).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeBottom).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Selection.Borders(xlEdgeRight).Weight = xlMedium[/COLOR]
[COLOR=#ff0000]    Sheets(1).Range("A8").Select[/COLOR]
[COLOR=#ff0000]End If[/COLOR]
Set c = Nothing:    Erase Arr
Application.ScreenUpdating = True
End Sub

Chuẩn men rồi bạn HiếuCD, cám ơn bạn rất nhiều

 

[Let'GâuGâu]

Chạy tốt bác ơi, nhưng sao chọn loại văn bản là "Tất cả các văn bản" thì báo ko tìm đc kết quả. Với cả có cách nào đánh số thứ tự kết quả từ 1 trở đi ko bác, kq nó ra stt như bên sheet2

tôi đang tập ado, khó chơi thật
muốn tìm hết các loại văn bảng thì ô từ khoá đe trống, nói chung là cái nào không muốn là đk thì cứ để trống
==
dùng vba điền số TT, ADO không làm được.....hihihi

 

[quynhbao]

Nhờ các Bạn xem giúp file mình áp dụng bị lỗi gì mình sửa hoài không được.
Thanks các Bạn nhé.