VBA cho Advanded filter (1 người xem)

[MinhKhai]

Lâu lắm không sử dụng Advanded filter và VBA, Nay có bài toán thấy khó quá nhờ các bác giúp
Không biết việc mọ mẫm đến Advandced Filter có phải là đúng hướng hay không mà em không xử lý được (dù đã thử record macro)
Mong được giúp đỡ
Vui lòng xem file đính kèm
Xin cảm ơn

 

[ptm0412]

Thứ nhất: Dữ liệu không có cột ngày tháng làm sao mà lọc?
Thứ hai: Advanced Filter không có tính năng tính tổng các dòng giống nhau. Pivot table thì ok

 

[MinhKhai]

Cảm ơn bác đã quan tâm.
1. Dữ liệu có ngày ngày tháng tại cột I mà bác ơi7
2. Sử dụng Advanced Filter là do em chưa biết giải pháp khác. Nếu sử dụng cách khác hoặc Pivot Table mà xử lý được vấn đề thì mong các bác giúp đỡ.

 

[ptm0412]

À. chỉ có tháng, không có ngày.

 

[MinhKhai]

À. chỉ có tháng, không có ngày.

Cảm ơn bác PTM. Giải pháp Pivot Table mà bác gợi ý tuy ra kết quả nhưng không thể sử dụng được vì mục đích cuối cùng là form ấy được dùng để in ngay ra làm đơn đặt hàng. Em mong chờ 1 giải pháp khác nhìn gọn gàng hơn.

 

[PacificPR]

Cảm ơn bác PTM. Giải pháp Pivot Table mà bác gợi ý tuy ra kết quả nhưng không thể sử dụng được vì mục đích cuối cùng là form ấy được dùng để in ngay ra làm đơn đặt hàng. Em mong chờ 1 giải pháp khác nhìn gọn gàng hơn.

Bạn thử dùng Code này xem sao

    Sub Tonghop()
    Dim Thang As Long, NCC As String
    Dim Dic As Object, I As Long, K As Long
    Dim Tem As String, sArr, dArr(1 To 65535, 1 To 6)
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TongHop")
    sArr = .Range(.[B5], .[B65536].End(xlUp)).Resize(, 9).Value2
End With
Thang = Sheets("DDH").Range("J3"): NCC = Sheets("DDH").Range("J4")
With Dic
    For I = 1 To UBound(sArr)
        If Thang = sArr(I, 8) Then
            If NCC = sArr(I, 9) Then
                Tem = sArr(I, 6)
                If Not .Exists(Tem) Then
                    K = K + 1
                    .Add Tem, K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 6): dArr(K, 3) = sArr(I, 2)
                    dArr(K, 4) = sArr(I, 3): dArr(K, 5) = sArr(I, 4): dArr(K, 6) = "=VLOOKUP(RC[-4],HH!R[-6]C[-4]:R[194]C[-1],4)"
                Else
                    dArr(.Item(Tem), 5) = dArr(.Item(Tem), 5) + sArr(I, 4)
                End If
            End If
        End If
    Next I
End With
With Sheets("DDH")
    .Range("C10:C68").EntireRow.Hidden = False
    .[A10:F68].ClearContents
    If K Then
        .[A10].Resize(K, 6).Value = dArr
        .Range("C10:C68").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    Else
        MsgBox "Khong tim thay du lieu", vbInformation, "Thong bao"
    End If
End With
Set Dic = Nothing
End Sub

 

[MinhKhai]

Bạn thử dùng Code này xem sao

    Sub Tonghop()
    Dim Thang As Long, NCC As String
    Dim Dic As Object, I As Long, K As Long
    Dim Tem As String, sArr, dArr(1 To 65535, 1 To 6)
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TongHop")
    sArr = .Range(.[B5], .[B65536].End(xlUp)).Resize(, 9).Value2
End With
Thang = Sheets("DDH").Range("J3"): NCC = Sheets("DDH").Range("J4")
With Dic
    For I = 1 To UBound(sArr)
        If Thang = sArr(I, 8) Then
            If NCC = sArr(I, 9) Then
                Tem = sArr(I, 6)
                If Not .Exists(Tem) Then
                    K = K + 1
                    .Add Tem, K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 6): dArr(K, 3) = sArr(I, 2)
                    dArr(K, 4) = sArr(I, 3): dArr(K, 5) = sArr(I, 4): dArr(K, 6) = "=VLOOKUP(RC[-4],HH!R[-6]C[-4]:R[194]C[-1],4)"
                Else
                    dArr(.Item(Tem), 5) = dArr(.Item(Tem), 5) + sArr(I, 4)
                End If
            End If
        End If
    Next I
End With
With Sheets("DDH")
    .Range("C10:C68").EntireRow.Hidden = False
    .[A10:F68].ClearContents
    If K Then
        .[A10].Resize(K, 6).Value = dArr
        .Range("C10:C68").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    Else
        MsgBox "Khong tim thay du lieu", vbInformation, "Thong bao"
    End If
End With
Set Dic = Nothing
End Sub

Cảm ơn bạn đã giúp đỡ. Code đã chạy như ý.
Tuy nhiên có 2 vấn đề là

1. Dòng lệnh trên chuyển vùng tham chiếu của hàm Vlookup sang địa chỉ tuyệt đối thì viết thế nào
2. Nếu muốn tính luôn trong code, (không cần hiện hàm tại ô kết quả thì viết lệnh như thế nào

Cảm ơn

 

[Nguyễn Hồng Quang]

Trước tiên mình rất cảm ơn Sharava36 đã tạo code cho đề tài này; giúp mình được mở mang tầm mắt và kiến thức trong biển trời VBA bao la rộng lớn
Mình cũng xin phép bạn Sharava36 trả lời nốt mấy vấn đề của bạn MinhKhai

Tuy nhiên có 2 vấn đề là
View attachment 174375
1. Dòng lệnh trên chuyển vùng tham chiếu của hàm Vlookup sang địa chỉ tuyệt đối thì viết thế nào
2. Nếu muốn tính luôn trong code, (không cần hiện hàm tại ô kết quả thì viết lệnh như thế nào

1. Copy paste đoạn code này

"=VLOOKUP(RC[-4],HH!R4C2:R204C5,4,0)"

" thay cho đoạn code gốc

=VLOOKUP(RC[-4],HH!R[-6]C[-4]:R[194]C[-1],4,0)

2. Nếu ko muốn hiện hàm tại ô kết qủa thì bổ sung vào phần dưới cùng tiếp sau

Set Dic = Nothing

đoạn code này

Range("F10").Select   
 Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

 

[PacificPR]

2. Nếu muốn tính luôn trong code, (không cần hiện hàm tại ô kết quả thì viết lệnh như thế nào

Nếu muốn không hiện hàm thì bạn thử thay dArr(k,6) thành:

dArr(K, 6) = Application.WorksheetFunction.VLookup(Tem, Sheets("HH").Range(Sheets("HH").[B4], Sheets("HH").[B65536].End(xlUp)).Resize(, 4), 4, False)

Hoặc

dArr(K, 6) = Sheets("HH").Range(Sheets("HH").[B4], Sheets("HH").[B65536].End(xlUp)).Resize(, 4).Find(Tem).Offset(, 3)

thử xem sao

 

[MinhKhai]

Cảm ơn các bác đã hướng dẫn. Code chạy trơn chu, chưa thấy lỗi
Em chỉ thắc mắc là có vẻ Advanded Filter trong VBA làm được việc này mà không thấy dùng. Thực tế thì nếu Advanced Filter thủ công thì vẫn được kết quả.

 

[lehuong1409]

hì tiện đây em share cách em hay làm với hàm, anh thay đổi xong chỉ cần ấn tổ hợp phím Ctrl Alt L (Reapply) là được ạ