Nhờ giúp code lọc báo cáo theo điều kiện từ 2 bảng dữ liệu

Liên hệ QC
D

duonghychi

Thành viên mới
Tham gia
17/4/17
Bài viết
38
Được thích
3
Em có file để lấy nguyên vật liệu yêu cầu theo ngày
Sheet (nguyên liệu) có những nguyên liệu cần lấy theo định lượng model
Sheet (Kế hoạch) là kế hoạch model sản xuất trong tháng
Sheets (lấy NVL theo KH) để em lấy NVL theo ngày dựa vào tổng các model
Em không biết diễn giải nên có lẽ sẽ khó hiểu, xin các anh chị giúp đỡ ạ.
Em cảm ơn mọi người ạ!
 

File đính kèm

  • KIT NVL theo KH.xlsm
    17.7 KB · Đọc: 21
Sắp xếp theo thời gian sắp xếp theo bầu chọn
duonghychi đã viết:
Em có file để lấy nguyên vật liệu yêu cầu theo ngày
Sheet (nguyên liệu) có những nguyên liệu cần lấy theo định lượng model
Sheet (Kế hoạch) là kế hoạch model sản xuất trong tháng
Sheets (lấy NVL theo KH) để em lấy NVL theo ngày dựa vào tổng các model
Em không biết diễn giải nên có lẽ sẽ khó hiểu, xin các anh chị giúp đỡ ạ.
Em cảm ơn mọi người ạ!
Nhấp chuột vào đây để mở rộng...
Thử xem file đính kèm trong khi chờ các giải pháp cao siêu khác
Tên các Sheet đã được đặt lại thành tên tiếng Việt không dấu.
 

File đính kèm

  • KIT NVL theo KH.xlsm
    30.8 KB · Đọc: 19
Upvote 0
duonghychi đã viết:
Em có file để lấy nguyên vật liệu yêu cầu theo ngày
Sheet (nguyên liệu) có những nguyên liệu cần lấy theo định lượng model
Sheet (Kế hoạch) là kế hoạch model sản xuất trong tháng
Sheets (lấy NVL theo KH) để em lấy NVL theo ngày dựa vào tổng các model
Em không biết diễn giải nên có lẽ sẽ khó hiểu, xin các anh chị giúp đỡ ạ.
Em cảm ơn mọi người ạ!
Nhấp chuột vào đây để mở rộng...
Thử code.
Mã: 
Sub laysoluong()
    Dim i As Long, lr As Long, dic As Object, arr, a As Long, KH, b As Long, ngay As Long, k As Long
    Dim dk As String, data, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         If lr < 7 Then Exit Sub
         .Range("F7:AJ" & lr).ClearContents
         arr = .Range("C6:AJ" & lr).Value
         For i = 4 To UBound(arr, 2)
             a = arr(1, i)
             dic.Item(a) = i
         Next i
         For i = 2 To UBound(arr)
             dk = arr(i, 1)
             dic.Item(dk) = i
         Next i
    End With
    With Sheet1
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         data = .Range("C5:F" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
   End With
   With Sheet7
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        KH = .Range("B4:D" & lr).Value
        For i = 1 To UBound(KH)
            dk = KH(i, 1)
            ngay = KH(i, 2)
            b = dic.Item(ngay)
            If b Then
               If dic.exists(dk) Then
                  T = dic.Item(dk)
                  For k = 0 To UBound(T)
                      dk = data(T(k), 2)
                      a = dic.Item(dk)
                      If a Then
                         arr(a, b) = arr(a, b) + KH(i, 3) * data(T(k), 4)
                         arr(a, 3) = arr(a, 3) + arr(a, b)
                      End If
                  Next k
               End If
           End If
        Next i
   End With
   With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         .Range("C6:AJ" & lr).Value = arr
   End With
Set dic = Nothing
End Sub
 
Upvote 0
HUONGHCKT đã viết:
Thử xem file đính kèm trong khi chờ các giải pháp cao siêu khác
Tên các Sheet đã được đặt lại thành tên tiếng Việt không dấu.
Nhấp chuột vào đây để mở rộng...
Tai sao lại viết câu lệnh này nhỉ bạn.
Mã: 
If Not dic Is Nothing Then Call Add_Dic
Mà nếu trong quá trình làm bên sheets nguyên liệu cập nhập thêm dữ liệu mới thì liệu Dic có cập nhập thêm không.
 
Upvote 0
snow25 đã viết:
Thử code.
Mã: 
Sub laysoluong()
    Dim i As Long, lr As Long, dic As Object, arr, a As Long, KH, b As Long, ngay As Long, k As Long
    Dim dk As String, data, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         If lr < 7 Then Exit Sub
         .Range("F7:AJ" & lr).ClearContents
         arr = .Range("C6:AJ" & lr).Value
         For i = 4 To UBound(arr, 2)
             a = arr(1, i)
             dic.Item(a) = i
         Next i
         For i = 2 To UBound(arr)
             dk = arr(i, 1)
             dic.Item(dk) = i
         Next i
    End With
    With Sheet1
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         data = .Range("C5:F" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
   End With
   With Sheet7
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        KH = .Range("B4:D" & lr).Value
        For i = 1 To UBound(KH)
            dk = KH(i, 1)
            ngay = KH(i, 2)
            b = dic.Item(ngay)
            If b Then
               If dic.exists(dk) Then
                  T = dic.Item(dk)
                  For k = 0 To UBound(T)
                      dk = data(T(k), 2)
                      a = dic.Item(dk)
                      If a Then
                         arr(a, b) = arr(a, b) + KH(i, 3) * data(T(k), 4)
                         arr(a, 3) = arr(a, 3) + arr(a, b)
                      End If
                  Next k
               End If
           End If
        Next i
   End With
   With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         .Range("C6:AJ" & lr).Value = arr
   End With
Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Chính xác luôn ạ, em cảm ơn ạ
HUONGHCKT đã viết:
Thử xem file đính kèm trong khi chờ các giải pháp cao siêu khác
Tên các Sheet đã được đặt lại thành tên tiếng Việt không dấu.
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh/chị ạ!
Em tải về bấm thì báo lỗi Run-time '91'. Object varialble or With block variable not set.
 
Upvote 0
snow25 đã viết:
Tai sao lại viết câu lệnh này nhỉ bạn.
Mã: 
If Not dic Is Nothing Then Call Add_Dic
Mà nếu trong quá trình làm bên sheets nguyên liệu cập nhập thêm dữ liệu mới thì liệu Dic có cập nhập thêm không.
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã xen bài. Tôi sót đoạn code bắt sự kiện thay đổi ở sheet NguyenLieu.
Sửa lại chỉ thêm
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C5:E10000")) Is Nothing Then
    If Dic Is Nothing Then Call Add_Dic
end sub
duonghychi đã viết:
Em cảm ơn anh/chị ạ!
Em tải về bấm thì báo lỗi Run-time '91'. Object varialble or With block variable not set.
Nhấp chuột vào đây để mở rộng...
Bạn thêm đoạn code trên vào trong modul sheet NguyenLieu.
Và thêm đoạn code ở Modul Workbook
Mã: 
Private Sub Workbook_Open()
Call Add_Dic
End Sub
lưu lại, đóng file, mở lại và nhấn mặt cười thử xem nó ra cái gì.
 
Upvote 0
HUONGHCKT đã viết:
Cảm ơn anh đã xen bài. Tôi sót đoạn code bắt sự kiện thay đổi ở sheet NguyenLieu.
Sửa lại chỉ thêm
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C5:E10000")) Is Nothing Then
    If Dic Is Nothing Then Call Add_Dic
end sub

Bạn thêm đoạn code trên vào trong modul sheet NguyenLieu.
Và thêm đoạn code ở Modul Workbook
Mã: 
Private Sub Workbook_Open()
Call Add_Dic
End Sub
lưu lại, đóng file, mở lại và nhấn mặt cười thử xem nó ra cái gì.
Nhấp chuột vào đây để mở rộng...
Nó không chạy được là do câu lệnh này mà.
Mã: 
If Not dic Is Nothing Then Call Add_Dic
 
Upvote 0
snow25 đã viết:
Nó không chạy được là do câu lệnh này mà.
Mã: 
If Not dic Is Nothing Then Call Add_Dic
Nhấp chuột vào đây để mở rộng...
Ở bài #7 tôi đã hướng dẫn cụ thể cho bạn đó rồi mà.
Tôi không biết bạn Test thế nào. Chứ tôi hiểu là:
Khi mở Workbook Sub Add_Dic sẽ chạy để nạp dic.
Khi thay đổi Sheet NguyenLieu Sub Add_Dic sẽ được gọi
Khi chạy Sub DuongHyChi sẽ kiểm tra xem đã có Dic chưa nếu chưa có thì Sub Add_dic được gọi.
 

File đính kèm

  • KIT NVL theo KH.xlsm
    32.5 KB · Đọc: 20
Lần chỉnh sửa cuối:
Upvote 0
HUONGHCKT đã viết:
Ở bài #7 tôi đã hướng dẫn cụ thể cho bạn đó rồi mà.
Tôi không biết bạn Test thế nào. Chứ tôi hiểu là:
Khi mở Workbook Sub Add_Dic sẽ chạy để nạp dic.
Khi thay đổi Sheet NguyenLieu Sub Add_Dic sẽ được gọi
Khi chạy Sub DuongHyChi sẽ kiểm tra xem đã có Dic chưa nếu chưa có thì Sub Add_dic được gọi.
Nhấp chuột vào đây để mở rộng...
Bạn có hiểu câu lệnh này không.
If Not dic Is Nothing Then Call Add_Dic
Bạn bỏ cái sự kiện mở file đi rồi chạy code xem nó có chạy được không.
 
Upvote 0
snow25 đã viết:
Bạn có hiểu câu lệnh này không.
If Not dic Is Nothing Then Call Add_Dic
Bạn bỏ cái sự kiện mở file đi rồi chạy code xem nó có chạy được không.
Nhấp chuột vào đây để mở rộng...
Cảm ơn Bạn. Tôi muốn là Khi chạy Sub DuongHyChi sẽ kiểm tra xem đã có Dic chưa nếu chưa có thì Sub Add_dic được gọi. Nhưng tôi đã nhầm( If not... is nothing = Không không có=có (phủ định của phủ định)).
Nên dòng trên phải được sửa lại thành If Dic is nothing then Add_Dic (bỏ Not)thì code chạy bình thường.
Đúng là gặp siêu nhân VBA có khác. Mà tại sao bạn không chỉ thẳng ra cho tôi hiểu mà lại cứ hỏi đi hỏi lại vậy?Tôi không tự ái đâu. Lên diễn đàn để học hỏi nhau thôi mà.
 
Upvote 0
HUONGHCKT đã viết:
Cảm ơn Bạn. Tôi muốn là Khi chạy Sub DuongHyChi sẽ kiểm tra xem đã có Dic chưa nếu chưa có thì Sub Add_dic được gọi. Nhưng tôi đã nhầm( If not... is nothing = Không không có=có (phủ định của phủ định)).
Nên dòng trên phải được sửa lại thành If Dic is nothing then Add_Dic (bỏ Not)thì code chạy bình thường.
Đúng là gặp siêu nhân VBA có khác. Mà tại sao bạn không chỉ thẳng ra cho tôi hiểu mà lại cứ hỏi đi hỏi lại vậy?Tôi không tự ái đâu. Lên diễn đàn để học hỏi nhau thôi mà.
Nhấp chuột vào đây để mở rộng...
Có lẽ là lỗi không hoàn toàn là tại câu lệnh đó.
File của bạn nạp dic ngay khi mở file nên câu lệnh đó là thừa. Việc chạy Add_dic có lẽ là chốt thực hiện cố định 1 nơi nào đó thì dễ quản lý hơn
 
Upvote 0
snow25 đã viết:
Thử code.
Mã: 
Sub laysoluong()
    Dim i As Long, lr As Long, dic As Object, arr, a As Long, KH, b As Long, ngay As Long, k As Long
    Dim dk As String, data, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         If lr < 7 Then Exit Sub
         .Range("F7:AJ" & lr).ClearContents
         arr = .Range("C6:AJ" & lr).Value
         For i = 4 To UBound(arr, 2)
             a = arr(1, i)
             dic.Item(a) = i
         Next i
         For i = 2 To UBound(arr)
             dk = arr(i, 1)
             dic.Item(dk) = i
         Next i
    End With
    With Sheet1
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         data = .Range("C5:F" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
   End With
   With Sheet7
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        KH = .Range("B4:D" & lr).Value
        For i = 1 To UBound(KH)
            dk = KH(i, 1)
            ngay = KH(i, 2)
            b = dic.Item(ngay)
            If b Then
               If dic.exists(dk) Then
                  T = dic.Item(dk)
                  For k = 0 To UBound(T)
                      dk = data(T(k), 2)
                      a = dic.Item(dk)
                      If a Then
                         arr(a, b) = arr(a, b) + KH(i, 3) * data(T(k), 4)
                         arr(a, 3) = arr(a, 3) + arr(a, b)
                      End If
                  Next k
               End If
           End If
        Next i
   End With
   With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         .Range("C6:AJ" & lr).Value = arr
   End With
Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cột tổng cộng có gì đó chưa ổn
Bài đã được tự động gộp:

snow25 đã viết:
Thử code.
Mã: 
Sub laysoluong()
    Dim i As Long, lr As Long, dic As Object, arr, a As Long, KH, b As Long, ngay As Long, k As Long
    Dim dk As String, data, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         If lr < 7 Then Exit Sub
         .Range("F7:AJ" & lr).ClearContents
         arr = .Range("C6:AJ" & lr).Value
         For i = 4 To UBound(arr, 2)
             a = arr(1, i)
             dic.Item(a) = i
         Next i
         For i = 2 To UBound(arr)
             dk = arr(i, 1)
             dic.Item(dk) = i
         Next i
    End With
    With Sheet1
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         data = .Range("C5:F" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
   End With
   With Sheet7
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        KH = .Range("B4:D" & lr).Value
        For i = 1 To UBound(KH)
            dk = KH(i, 1)
            ngay = KH(i, 2)
            b = dic.Item(ngay)
            If b Then
               If dic.exists(dk) Then
                  T = dic.Item(dk)
                  For k = 0 To UBound(T)
                      dk = data(T(k), 2)
                      a = dic.Item(dk)
                      If a Then
                         arr(a, b) = arr(a, b) + KH(i, 3) * data(T(k), 4)
                         arr(a, 3) = arr(a, 3) + arr(a, b)
                      End If
                  Next k
               End If
           End If
        Next i
   End With
   With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         .Range("C6:AJ" & lr).Value = arr
   End With
Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cột tổng cộng có gì đó chưa ổn
 
Upvote 0
HieuCD đã viết:
Cột tổng cộng có gì đó chưa ổn
Bài đã được tự động gộp:


Cột tổng cộng có gì đó chưa ổn
Nhấp chuột vào đây để mở rộng...
Em không để ý cộng 2 lần.Bạn sửa lại code.
Mã: 
Sub laysoluong()
    Dim i As Long, lr As Long, dic As Object, arr, a As Long, KH, b As Long, ngay As Long, k As Long
    Dim dk As String, data, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         If lr < 7 Then Exit Sub
         .Range("E7:AJ" & lr).ClearContents
         arr = .Range("C6:AJ" & lr).Value
         For i = 4 To UBound(arr, 2)
             a = arr(1, i)
             dic.Item(a) = i
         Next i
         For i = 2 To UBound(arr)
             dk = arr(i, 1)
             dic.Item(dk) = i
         Next i
    End With
    With Sheet1
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         data = .Range("C5:F" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
   End With
   With Sheet7
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        KH = .Range("B4:D" & lr).Value
        For i = 1 To UBound(KH)
            dk = KH(i, 1)
            ngay = KH(i, 2)
            b = dic.Item(ngay)
            If b Then
               If dic.exists(dk) Then
                  T = dic.Item(dk)
                  For k = 0 To UBound(T)
                      dk = data(T(k), 2)
                      a = dic.Item(dk)
                      If a Then
                         arr(a, b) = arr(a, b) + KH(i, 3) * data(T(k), 4)
                         arr(a, 3) = arr(a, 3) + KH(i, 3) * data(T(k), 4)
                      End If
                  Next k
               End If
           End If
        Next i
   End With
   With Sheet2
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         .Range("C6:AJ" & lr).Value = arr
   End With
Set dic = Nothing
End Sub
 
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
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
37
sakurasumo
S
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
6
Đọc
121
Hoàng Tuấn 868
H
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
619
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
104
ptm0412
ptm0412
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
191
Đọc
10K
ongke0711
ongke0711
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
228
CNKyNguyen
CNKyNguyen
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
9
Đọc
404
vostro 1500
vostro 1500
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
0
Đọc
61
THU UYEN317
T
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
230
yeudoi
yeudoi
OverAC
Thông báo nội dung xấu và bài viết vi phạm nội quy.
19 20 21
Trả lời
416
Đọc
41K
vanle33
vanle33
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
2
Đọc
69
Silklynk
S
B
Sắp xếp lịch trực
5 6 7
Trả lời
130
Đọc
86K
TTVAN28
TTVAN28
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
4
Đọc
141
nguyenthieny
N
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
87
bebo021999
B
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
4
Đọc
103
hoaithanh9480
hoaithanh9480
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
2
Đọc
136
hoangtuaotrang_hp_vn
H
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
    • Yêu thích
Trả lời
1
Đọc
99
HUONGHCKT
H
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
14
Đọc
294
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
240
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
58
ongke0711
ongke0711
Xem thêm…

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