Lọc - trích dữ liệu theo điều kiện (3 người xem)

Excel365 · 25/3/14

Nhờ các anh chị giúp em viết code lọc - trích dữ liệu theo điều kiên.
Trân trọng cảm ơn

ChanhTQ@ · 25/3/14

Bạn xem file đính kèm

Sử dụng macro sự kiện để hiện kết quả

Excel365 · 25/3/14

ChanhTQ@ đã viết:
Sử dụng macro sự kiện để hiện kết quả

ChanhTQ@ xem giúp em sao mà nó trích lọc sót dữ liệu
VD:
Phòng TCHC có 9 người những nó chỉ trích sang sheet IN có 8 người
Với lại giúp em kẻ khung cho vùng có dữ liệu trích sang nhe

concogia · 25/3/14

Góp "zí" bác Sa một cái cho "dzui"
Thân

leonguyenz · 25/3/14

Em viết mảng, mà nhìn không ổn ...
[gpecode=vb]Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [F1]) Is Nothing Then
Dim eR As Long, iR As Long, jR As Long, kR As Long, sArr(), rArr()
Dim eR2 As Long, bpFind As Range
eR = Sheets("DULIEU").Range("AN65535").End(xlUp).Row
sArr = Sheets("DULIEU").Range("A5:AN" & eR).Value2
eR2 = Sheets("IN").Range("C65535").End(xlUp).Row
Sheets("IN").Range("A7:A" & eR2 - 7).EntireRow.Delete
Set bpFind = Sheet1.Range("A2:A11").Find(Target.Value, , xlFormulas, xlWhole)
If Not bpFind Is Nothing Then
Sheets("IN").Range("C6") = bpFind.Offset(, 1)
End If
ReDim rArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
For iR = LBound(sArr, 1) To UBound(sArr, 1)
If sArr(iR, UBound(sArr, 2)) = Target.Value Then
kR = kR + 1
For jR = LBound(sArr, 2) To UBound(sArr, 2)
rArr(kR, jR) = sArr(iR, jR)
Next jR
End If
Next iR
Sheets("IN").Range("A7:A" & kR + 7).EntireRow.Insert
Sheets("IN").Range("A7").Resize(kR, UBound(sArr, 2)) = rArr
End If
End Sub[/gpecode]
Cái phần Insert, Delete, ... nhờ sư phụ chỉ dùm, thay vì Hide như bác Cò, nếu Delete rồi Insert thì phải làm thế nào?
**** Đã sửa phần Insert, Delete. Còn Format nữa.

SA_DQ · 25/3/14

Bạn lấy macro này thay thế nè!

ChanhTQ@ xem giúp em sao mà nó trích lọc sót dữ liệu
VD:
Phòng TCHC có 9 người những nó chỉ trích sang sheet IN có 8 người
Với lại giúp em kẻ khung cho vùng có dữ liệu trích sang nhe

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F1]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range
    Dim TenDV As String, Rws As Long
 
    Set sRng = Sheets("Main").Range("A1:A99").Find(Target.Value, , xlFormulas, xlWhole).Offset(, 1)
    Rows("6:39").Hidden = False         '<=}'
    [A6].Resize(40, 40).ClearContents
    If sRng Is Nothing Then
        MsgBox "Nothing"
    Else
        TenDV = sRng.Value
        Set Sh = ThisWorkbook.Worksheets("DuLieu")
        Set Rng = Sh.Range(Sh.[c5], Sh.[C65500].End(xlUp))
        Set sRng = Rng.Find(TenDV)
        If sRng Is Nothing Then
            MsgBox "No more"
        Else
            Rws = sRng.Offset(1, 1).End(xlDown).Row
            If Rws > 65500 Then Rws = Sh.[C65500].End(xlUp).Row
            Rws = Rws - sRng.Row + 1            '*'
            [A6].Resize(Rws, 40).Value = Sh.Cells(sRng.Row, "A").Resize(Rws, 40).Value      '*'
            Rows(8 + Rws & ":39").Hidden = True
        End If
    End If
 End If
End Sub

Nhớ kẻ khung trước từ dòng 6:40
& Cảm ơn ConCoGia nhiều!

concogia · 25/3/14

leonguyenz đã viết:
Em viết mảng, mà nhìn không ổn ...
[gpecode=vb]Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [F1]) Is
........
End Sub[/gpecode]
Cái phần Insert, Delete, ... nhờ sư phụ chỉ dùm, thay vì Hide như bác Cò, nếu Delete rồi Insert thì phải làm thế nào?
**** Đã sửa phần Insert, Delete. Còn Format nữa.

Format gì vậy Leo, đóng khung ??? +-+-+-+

Bạn chủ topic cần:

1- lọc và trích xuất dữ liều từ Sheet DULIEU sang sheet IN theo diều kiện ở ô f1
2- Tự động kẻ khung vùng dữ liệu được trích xuất sang
3 - Cuối vung dữ liệu được trích sang sheet IN chèn thêm vùng tô màu A12:AN17

Phần 1 thì làm kiểu quái nào thì tùy vì có nhiều cách viết. Mình chọn cách xác định vùng cần lọc, copy mang qua sheet kết quả, được khuyến mãi cái khung, hihi.
Phần 2 - kẻ khung thì mình giữ nguyên khung, dấu phần trống, khỏi kẻ ==> "phẻ" re
Phần 3 - để sẵn phần cần chèn ( màu sậm ) dấu phần trống sẽ lòi ra em đó, khỏi chèn ==> "phẻ" re
Hình như cái bảng này để tham khảo hay in báo cáo gì đó nên mình ẩn hàng đi cũng chẳng ảnh hưởng gì lớn
Híc
Thân

Lê Duy Thương · 26/3/14

HYen17 đã viết:

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F1]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range
    Dim TenDV As String, Rws As Long
 
    Set sRng = Sheets("Main").Range("A1:A99").Find(Target.Value, , xlFormulas, xlWhole).Offset(, 1)
    Rows("6:39").Hidden = False         '<=}'
    [A6].Resize(40, 40).ClearContents
    If sRng Is Nothing Then
        MsgBox "Nothing"
    Else
        TenDV = sRng.Value
        Set Sh = ThisWorkbook.Worksheets("DuLieu")
        Set Rng = Sh.Range(Sh.[c5], Sh.[C65500].End(xlUp))
        Set sRng = Rng.Find(TenDV)
        If sRng Is Nothing Then
            MsgBox "No more"
        Else
            Rws = sRng.Offset(1, 1).End(xlDown).Row
            If Rws > 65500 Then Rws = Sh.[C65500].End(xlUp).Row
            Rws = Rws - sRng.Row + 1            '*'
            [A6].Resize(Rws, 40).Value = Sh.Cells(sRng.Row, "A").Resize(Rws, 40).Value      '*'
            Rows(8 + Rws & ":39").Hidden = True
        End If
    End If
 End If
End Sub

Nhớ kẻ khung trước từ dòng 6:40
& Cảm ơn ConCoGia nhiều!

SAO BÁC SA+BÁC CÒ+LEO KHÔNG DÙNG ADVANCE FILTER NHỈ @#!^%

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$F$1" Then
    Sheet2.[5:5000].Clear
    Sheet7.[A5:AN5000].AdvancedFilter 2, Sheet7.[AO1:AO2], [A5]
    Sheet7.[A5000].End(3).Offset(1, 0).Resize(9, 40).Copy Sheet2.[A5000].End(3).Offset(1, 0)
    End If
    
End Sub

SA_DQ · 26/3/14

Thế chú mày có thử chưa, hử?

[thongbao]sao bác sa + bác cò+leo không dùng advance filter nhỉ @#!^%

[/thongbao]

concogia · 26/3/14

Lê Duy Thương đã viết:
SAO BÁC SA+BÁC CÒ+LEO KHÔNG DÙNG ADVANCE FILTER NHỈ

PHP:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$F$1" Then Sheet2.[5:5000].Clear Sheet7.[A5:AN5000].AdvancedFilter 2, Sheet7.[AO1:AO2], [A5] Sheet7.[A5000].End(3).Offset(1, 0).Resize(9, 40).Copy Sheet2.[A5000].End(3).Offset(1, 0) End If End Sub

Híc, đã bảo:

Phần 1 thì làm kiểu quái nào thì tùy vì có nhiều cách viết.

Còn nếu dùng bộ lọc thì phang luôn cái Auto Filter cho rồi, khỏi phải chèn thêm [AO1:AO2] cho nó.......xấu bảng tính của người ta đi. Híc
Lâu quá hông nhậu "zí" chú em, còn lên "Sì- Gòn" thường hông ? dám......nhậu hông ????

Lê Duy Thương · 26/3/14

concogia đã viết:
híc, đã bảo:

Còn nếu dùng bộ lọc thì phang luôn cái auto filter cho rồi, khỏi phải chèn thêm [ao1:ao2] cho nó.......xấu bảng tính của người ta đi. Híc
lâu quá hông nhậu "zí" chú em, còn lên "sì- gòn" thường hông ? Dám......nhậu hông ????

em vẫn thường xuyên xì gòn 5 ngày /tuần. Bác thích thì hôm nào em chìu _)(#;

Excel365 · 29/3/14

concogia đã viết:
Góp "zí" bác Sa một cái cho "dzui"
Thân

Bác oi cho em hỏi
Em muốn lọc những người là BTGĐ ( ở cột BỘ PHẬN) chứ không phải là những người thuôc bộ phận đó
VD: trong Bộ phận ban Tổng giám đốc có 4 người, nhưng chức danh BTGĐ thì chỉ có 3 người và 1 người là KTT. Nay em muốn chỉ lọc ra 3 người có chức danh là KTT

Trân trọng cảm ơn

SA_DQ · 29/3/14

Bạn thay macro này vô bài #6

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F1]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range
    Dim TenDV As String, Rws As Long
 
    Set sRng = Sheets("Main").Range("A1:A99").Find(Target.Value, , xlFormulas, xlWhole).Offset(, 1)
    Rows("6:39").Hidden = False
    [A6].Resize(40, 40).ClearContents
    If sRng Is Nothing Then
        MsgBox "Nothing"
    Else
        TenDV = sRng.Value
        Set Sh = ThisWorkbook.Worksheets("DuLieu")
        Set Rng = Sh.Range(Sh.[c5], Sh.[C65500].End(xlUp))
        Set sRng = Rng.Find(TenDV)
        If sRng Is Nothing Then
            MsgBox "No more"
        Else
            Rws = sRng.Offset(1, 1).End(xlDown).Row
            If Rws > 65500 Then Rws = Sh.[C65500].End(xlUp).Row
            Rws = Rws - sRng.Row + 1
            [A6].Resize(Rws, 40).Value = Sh.Cells(sRng.Row, "A").Resize(Rws, 40).Value
            Rows(8 + Rws & ":39").Hidden = True
        End If
    End If
9  '*   *   *   *   *   *   *   *   *   '
    If Left(Target.Value, 3) = "BTG" Then
        TenDV = InputBox("KTT" & Chr(10) & "BTGD", "Ban Muón Hien Thi Chúc Danh Nào?")
        TenDV = UCase$(TenDV)
        For Each Rng In Range("F7:F10")
            If (Left(TenDV, 1) = "K" And Left(Rng.Value, 1) <> "K") _
                Or (Left(TenDV, 1) <> "K" And Left(Rng.Value, 1) = "K") Then
                Rng.EntireRow.Hidden = True
            End If
        Next Rng
    End If
 End If
End Sub

Excel365 · 29/3/14

HYen17 đã viết:

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F1]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range
    Dim TenDV As String, Rws As Long
 
    Set sRng = Sheets("Main").Range("A1:A99").Find(Target.Value, , xlFormulas, xlWhole).Offset(, 1)
    Rows("6:39").Hidden = False
    [A6].Resize(40, 40).ClearContents
    If sRng Is Nothing Then
        MsgBox "Nothing"
    Else
        TenDV = sRng.Value
        Set Sh = ThisWorkbook.Worksheets("DuLieu")
        Set Rng = Sh.Range(Sh.[c5], Sh.[C65500].End(xlUp))
        Set sRng = Rng.Find(TenDV)
        If sRng Is Nothing Then
            MsgBox "No more"
        Else
            Rws = sRng.Offset(1, 1).End(xlDown).Row
            If Rws > 65500 Then Rws = Sh.[C65500].End(xlUp).Row
            Rws = Rws - sRng.Row + 1
            [A6].Resize(Rws, 40).Value = Sh.Cells(sRng.Row, "A").Resize(Rws, 40).Value
            Rows(8 + Rws & ":39").Hidden = True
        End If
    End If
9  '*   *   *   *   *   *   *   *   *   '
    If Left(Target.Value, 3) = "BTG" Then
        TenDV = InputBox("KTT" & Chr(10) & "BTGD", "Ban Muón Hien Thi Chúc Danh Nào?")
        TenDV = UCase$(TenDV)
        For Each Rng In Range("F7:F10")
            If (Left(TenDV, 1) = "K" And Left(Rng.Value, 1) <> "K") _
                Or (Left(TenDV, 1) <> "K" And Left(Rng.Value, 1) = "K") Then
                Rng.EntireRow.Hidden = True
            End If
        Next Rng
    End If
 End If
End Sub

Cám ơn HYEN17 nhiều, nhưng bạn có thể chỉnh lại giúp mình lọc danh sách dựa vô cột AN (cột 40).
khi mình chọn điều kien ở ô F1 sheet IN thì sẽ lọc những người có chức danh giống như cột AN và chèn thêm dòng ghi chú chấm công ở dưới
Thank!

ChanhTQ@ · 29/3/14

. . . , nhưng bạn có thể chỉnh lại giúp mình lọc danh sách dựa vô cột AN (cột 40).
khi mình chọn điều kien ở ô F1 sheet IN thì sẽ lọc những người có chức danh giống như cột AN và chèn thêm dòng ghi chú chấm công ở dưới
Thank!

Nếu lọc theo cột [AN], thì khi đó, kết quả lọc sẽ không có ngay tên đơn vị như mẫu tại bài 1 của bạn;
Hơn nữa, khi lọc BTGĐ cũng sẽ f ải xử lí bổ sung để loại bỏ người không cần tới.
Công việc lọc này cũng không nhanh hơn bao nhiêu về tốc độ so với bây giờ bạn đã đạt.
Theo yêu cầu của bạn, ta chỉ cần chép các dòng từ 12-> 17 trong form mẫu dán vô vùng bắt đầu bỡi [A46] là đạt rồi còn gì!
Sau mỗi lần chạy macro, các dòng chưa có số liệu sẽ bị ẩn đi mà!

Excel365 · 29/3/14

ChanhTQ@ đã viết:
Nếu lọc theo cột [AN], thì khi đó, kết quả lọc sẽ không có ngay tên đơn vị như mẫu tại bài 1 của bạn;
Hơn nữa, khi lọc BTGĐ cũng sẽ f ải xử lí bổ sung để loại bỏ người không cần tới.
Công việc lọc này cũng không nhanh hơn bao nhiêu về tốc độ so với bây giờ bạn đã đạt.
Theo yêu cầu của bạn, ta chỉ cần chép các dòng từ 12-> 17 trong form mẫu dán vô vùng bắt đầu bỡi [A46] là đạt rồi còn gì!
Sau mỗi lần chạy macro, các dòng chưa có số liệu sẽ bị ẩn đi mà!

Cám ơn ChanhTQ@.
Em cũng không cần tiều đề như tên đơn vi ở #1, (tên đơn vi thì em xó thể làm dò tiềm từ 1 bảng phụ khác) mà chỉ cần lọc ra những
người thỏa mãn yêu cầu ở cột AN
Trân trọng cảm ơn

ChanhTQ@ · 29/3/14

Cám ơn ChanhTQ@.
Em cũng không cần tiều đề như tên đơn vi ở #1, (tên đơn vi thì em xó thể làm dò tiềm từ 1 bảng phụ khác) mà chỉ cần lọc ra những
người thỏa mãn yêu cầu ở cột AN
Trân trọng cảm ơn

(/ậy thì xem bài của chàng Le Duy Thương mà fát triển hay nhờ chàng ta giúp tiếp!

Lọc - trích dữ liệu theo điều kiện (3 người xem)

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

Thành viên tích cực

File đính kèm

0901452không62

File đính kèm

Thành viên tích cực

Gội rồi mới Cạo

File đính kèm

Thành viên gạo cội

/(hông là gì!

Gội rồi mới Cạo

Cạo lấy gì gội (Dịch quá không gội được)

File đính kèm

/(hông là gì!

Gội rồi mới Cạo

Cạo lấy gì gội (Dịch quá không gội được)

Thành viên tích cực

/(hông là gì!

Thành viên tích cực

0901452không62

Thành viên tích cực

0901452không62

Đếm ngược thời gian