Xin giúp đỡ code lọc hàng hóa theo ngày

Liên hệ QC
dvh.hy.9902

dvh.hy.9902

Thành viên hoạt động
Tham gia
27/3/12
Bài viết
123
Được thích
9
Xin chào các anh chị và các bạn.
Mong các anh chi và các bạn giúp tôi code vba lọc hàng hóa theo ngày như trong file đính kèm như sau!.
Tại sheet(Lọc_hang_theo_ngay) khi chọn ngày tại ô K3 thì các mặt hàng tại ngày tương ứng bên sheet (Danh_mc_hang) ứng với ngày đó ở trong tháng được lấy với các mặt hàng có số lượng được lấy. (mặt hàng nào không có số lượng hàng hóa thì không lấy)
Tôi xin cảm ơn rất nhiều!.
 

File đính kèm

  • loc hang theo ngay.xlsb
    27.5 KB · Đọc: 21
Sắp xếp theo thời gian sắp xếp theo bầu chọn
dvh.hy.9902 đã viết:
Xin chào các anh chị và các bạn.
Mong các anh chi và các bạn giúp tôi code vba lọc hàng hóa theo ngày như trong file đính kèm như sau!.
Tại sheet(Lọc_hang_theo_ngay) khi chọn ngày tại ô K3 thì các mặt hàng tại ngày tương ứng bên sheet (Danh_mc_hang) ứng với ngày đó ở trong tháng được lấy với các mặt hàng có số lượng được lấy. (mặt hàng nào không có số lượng hàng hóa thì không lấy)
Tôi xin cảm ơn rất nhiều!.
Nhấp chuột vào đây để mở rộng...
Code cho Module:
Mã: 
Sub FilterByDate()
    Dim Dat As Range, sArr(), dArr(), Col As Integer
    Dim I As Long, J As Long, K As Long
    
    Sheet3.Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        Col = Application.Match(Sheet3.Range("K3"), Dat, 0) + 3
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, Col).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
    
    For I = 1 To UBound(sArr, 1)
        If sArr(I, Col) Then
            K = K + 1: dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, Col): dArr(K, 5) = sArr(I, 3)
            dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
        End If
    Next I
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Code cho Sheets("Lọc_hang_theo_ngay")
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$K$3" Then
        Call FilterByDate
    End If
End Sub
Chúc bạn thành công.
 
Upvote 0
vanthinh3101 đã viết:
Code cho Module:
Mã: 
Sub FilterByDate()
    Dim Dat As Range, sArr(), dArr(), Col As Integer
    Dim I As Long, J As Long, K As Long
 
    Sheet3.Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        Col = Application.Match(Sheet3.Range("K3"), Dat, 0) + 3
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, Col).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
 
    For I = 1 To UBound(sArr, 1)
        If sArr(I, Col) Then
            K = K + 1: dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, Col): dArr(K, 5) = sArr(I, 3)
            dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
        End If
    Next I
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Code cho Sheets("Lọc_hang_theo_ngay")
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$K$3" Then
        Call FilterByDate
    End If
End Sub
Chúc bạn thành công.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn đã nhiệt tình giúp mình!. Mình kiểm tra code thấy kết quả như mong muốn rồi!.
- Mong bạn và mọi người giúp mình thêm một chút nữa ạ!:
- Tại ô [I3] sheet Sheets("Lọc_hang_theo_ngay") mình chọn các ngày cần lọc ví dụ từ ngày 18-20, 22 thì (lọc và cộng dồn các mặt hàng cùng loại rồi nhân với đơn giá để ra cột thành tiền).
- Hoặc là mình có thể lọc những ngày bất kỳ mà mình nhập vào ô [I3] Ví dụ: 18;19;21;22... (lọc và cộng dồn các mặt hàng cùng loại rồi nhân với đơn giá để ra cột thành tiền).
- Mình rất mong được sự giúp đỡ của bạn và mọi người!.
 
Lần chỉnh sửa cuối:
Upvote 0
Mình chưa xem file của bạn, nhưng mình cũng hay lọc theo ngày.
Thường mình sẽ dùng hàm countifs để lọc, với điều kiện data dữ liệu của bạn cũng có cột ngày tháng
 
Upvote 0
valama đã viết:
Mình chưa xem file của bạn, nhưng mình cũng hay lọc theo ngày.
Thường mình sẽ dùng hàm countifs để lọc, với điều kiện data dữ liệu của bạn cũng có cột ngày tháng
Nhấp chuột vào đây để mở rộng...
Mình mốn dùng code để lọc. Trước hết là có thể xem từng ngày; nhưng có khi vài ngày mình mới cần lọc ra đẻ tổng hợp lại.
Mọi người vào xem và nghiên cứ giúp mình với!.
 
Upvote 0
dvh.hy.9902 đã viết:
Cảm ơn bạn đã nhiệt tình giúp mình!. Mình kiểm tra code thấy kết quả như mong muốn rồi!.
- Mong bạn và mọi người giúp mình thêm một chút nữa ạ!:
- Tại ô [I3] sheet Sheets("Lọc_hang_theo_ngay") mình chọn các ngày cần lọc ví dụ từ ngày 18-20, 22 thì (lọc và cộng dồn các mặt hàng cùng loại rồi nhân với đơn giá để ra cột thành tiền).
- Hoặc là mình có thể lọc những ngày bất kỳ mà mình nhập vào ô [I3] Ví dụ: 18;19;21;22... (lọc và cộng dồn các mặt hàng cùng loại rồi nhân với đơn giá để ra cột thành tiền).
- Mình rất mong được sự giúp đỡ của bạn và mọi người!.
Nhấp chuột vào đây để mở rộng...
Code cho yêu cầu tổng hợp
Mã: 
Sub FilterAndConsolidate()
    Dim Dat As Range, sArr(), dArr(), tArr(), Tmp, Dic As Object
    Dim I As Long, J As Long, K As Long, Col As Integer
    
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, 35).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
    With Sheet3
        .Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
        Tmp = Split(.Range("I3"), ";")
    End With
    
    For J = 0 To UBound(Tmp)
        Col = Application.Match(Val(Tmp(J)), Dat, 0) + 3
        For I = 1 To UBound(sArr, 1)
            If sArr(I, Col) Then
                If Not Dic.exists(sArr(I, 1)) Then
                    K = K + 1: Dic.Add sArr(I, 1), K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2): dArr(K, 5) = sArr(I, 3)
                    dArr(K, 4) = sArr(I, Col): dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
                Else
                    dArr(Dic.Item(sArr(I, 1)), 4) = dArr(Dic.Item(sArr(I, 1)), 4) + sArr(I, Col)
                End If
            End If
        Next I
    Next J
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
    Set Dic = Nothing: Set Dat = Nothing
End Sub
1 số lưu ý:
- Thông tin các ngày cần tổng hợp được để tại ô I3
- Giữa các ngày được phân tách bằng dấu ";"
Chúc bạn thành công.
 
Upvote 0
vanthinh3101 đã viết:
Code cho yêu cầu tổng hợp
Mã: 
Sub FilterAndConsolidate()
    Dim Dat As Range, sArr(), dArr(), tArr(), Tmp, Dic As Object
    Dim I As Long, J As Long, K As Long, Col As Integer
  
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, 35).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
    With Sheet3
        .Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
        Tmp = Split(.Range("I3"), ";")
    End With
  
    For J = 0 To UBound(Tmp)
        Col = Application.Match(Val(Tmp(J)), Dat, 0) + 3
        For I = 1 To UBound(sArr, 1)
            If sArr(I, Col) Then
                If Not Dic.exists(sArr(I, 1)) Then
                    K = K + 1: Dic.Add sArr(I, 1), K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2): dArr(K, 5) = sArr(I, 3)
                    dArr(K, 4) = sArr(I, Col): dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
                Else
                    dArr(Dic.Item(sArr(I, 1)), 4) = dArr(Dic.Item(sArr(I, 1)), 4) + sArr(I, Col)
                End If
            End If
        Next I
    Next J
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
    Set Dic = Nothing: Set Dat = Nothing
End Sub
1 số lưu ý:
- Thông tin các ngày cần tổng hợp được để tại ô I3
- Giữa các ngày được phân tách bằng dấu ";"
Chúc bạn thành công.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nghiên cứu giúp mình!.
Mình kiểm tra dữ liệu: Khi mình nhập vào ngày ví dụ khi nhập ngày cần tìm là: 19;20;21 thì cột thành tiền chưa cho kết quả đúng. Két quả đúng nó phải là tổng số lượng nhân với đơn giá. (Cụ thể là nước Sting đỏ tổng hợp 3 ngày trên là 216 chai. Giả sử cột đơn giá bên sheet(Danh_muc_hang) mình nhập là 9000 "như vậy sẽ là 216*9000=1944000; code chưa có phép tính nhân cho kết quả này. Bạn xem và giúp mình với. Mình cảm ơn bạn nhiều!.
 
Lần chỉnh sửa cuối:
Upvote 0
dvh.hy.9902 đã viết:
Cảm ơn bạn nghiên cứu giúp mình!.
Mình kiểm tra dữ liệu: Khi mình nhập vào ngày ví dụ khi nhập ngày cần tìm là: 19;20;21 thì cột thành tiền chưa cho kết quả đúng. Két quả đúng nó phải là tổng số lượng nhân với đơn giá. (Cụ thể là nước Sting đỏ tổng hợp 3 ngày trên là 216 chai. Giả sử cột đơn giá bên sheet(Danh_muc_hang) mình nhập là 9000 "như vậy sẽ là 216*9000=1944000; code chưa có phép tính nhân cho kết quả này. Bạn xem và giúp mình với. Mình cảm ơn bạn nhiều!.
Nhấp chuột vào đây để mở rộng...
Bạn thử lại
Mã: 
Sub FilterAndConsolidate()
    Dim Dat As Range, sArr(), dArr(), tArr(), Tmp, Dic As Object
    Dim I As Long, J As Long, K As Long, Col As Integer
    
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, 35).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
    With Sheet3
        .Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
        Tmp = Split(.Range("I3"), ";")
    End With
    
    For J = 0 To UBound(Tmp)
        Col = Application.Match(Val(Tmp(J)), Dat, 0) + 3
        For I = 1 To UBound(sArr, 1)
            If sArr(I, Col) Then
                If Not Dic.exists(sArr(I, 1)) Then
                    K = K + 1: Dic.Add sArr(I, 1), K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2): dArr(K, 5) = sArr(I, 3)
                    dArr(K, 4) = sArr(I, Col): dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
                Else
                    dArr(Dic.Item(sArr(I, 1)), 4) = dArr(Dic.Item(sArr(I, 1)), 4) + sArr(I, Col)
                    dArr(Dic.Item(sArr(I, 1)), 6) = dArr(Dic.Item(sArr(I, 1)), 4) * dArr(Dic.Item(sArr(I, 1)), 5)    'them dong nay'
                End If
            End If
        Next I
    Next J
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
    Set Dic = Nothing: Set Dat = Nothing
End Sub
 
Upvote 0
vanthinh3101 đã viết:
Bạn thử lại
Mã: 
Sub FilterAndConsolidate()
    Dim Dat As Range, sArr(), dArr(), tArr(), Tmp, Dic As Object
    Dim I As Long, J As Long, K As Long, Col As Integer
   
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Set Dat = .Range("F3:AJ3")
        sArr() = .Range("C4", .Range("C4").End(xlDown)).Resize(, 35).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To 6)
    With Sheet3
        .Range("A9", Sheet3.Range("A9").End(xlDown)).Resize(, 6).Clear
        Tmp = Split(.Range("I3"), ";")
    End With
   
    For J = 0 To UBound(Tmp)
        Col = Application.Match(Val(Tmp(J)), Dat, 0) + 3
        For I = 1 To UBound(sArr, 1)
            If sArr(I, Col) Then
                If Not Dic.exists(sArr(I, 1)) Then
                    K = K + 1: Dic.Add sArr(I, 1), K
                    dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2): dArr(K, 5) = sArr(I, 3)
                    dArr(K, 4) = sArr(I, Col): dArr(K, 6) = dArr(K, 4) * dArr(K, 5)
                Else
                    dArr(Dic.Item(sArr(I, 1)), 4) = dArr(Dic.Item(sArr(I, 1)), 4) + sArr(I, Col)
                    dArr(Dic.Item(sArr(I, 1)), 6) = dArr(Dic.Item(sArr(I, 1)), 4) * dArr(Dic.Item(sArr(I, 1)), 5)    'them dong nay'
                End If
            End If
        Next I
    Next J
    If K Then
        Sheet3.Range("A9").Resize(K, 6) = dArr
        Sheet3.Range("A9").CurrentRegion.Font.Name = "Times New Roman"
        Sheet3.Range("A9").CurrentRegion.Font.Size = 13
        Sheet3.Range("A9").CurrentRegion.Borders.LineStyle = 1
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
    Set Dic = Nothing: Set Dat = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
- Code chạy ok rồi!. Cảm ơn bạn đã nhiệt tình giúp mình. Trong quá trình sử dụng nếu có gì vướng mắc rất mong được sự giúp đỡ của bạn và mọi người.
- Một lần nữa xin cảm ơn bạn nhiều!.
 
Upvote 0
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

S
Slicer không chuyển qua trạng thái mờ.
Trả lời
0
Đọc
2
SteveNguyen1991
S
V
Không chạy được vba ở sheet khác
Trả lời
2
Đọc
446
Emyeuexcel
Emyeuexcel
Hai Lúa Miền Tây
  • Dán lên cao
Khai thác và tùy biến thêm, sửa, xuất file và lấy dữ liệu từ Recordset
    • Thích
    • Yêu thích
9 10 11
Trả lời
207
Đọc
18K
Quang_Hải
Quang_Hải
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
8
Đọc
199
Emyeuexcel
Emyeuexcel
th7
Hỗ trợ công thức để lấy kết quả dựa theo nút danh sách thả xuống (Drop List) và bảng dữ liệu.
Trả lời
1
Đọc
30
HUONGHCKT
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom