Lấy số lượng theo định mức sản xuất bằng VBA

[thinhnx22]

Chào các bạn,
Trong file đính kèm, ở cột F sheet NXT, mình muốn nhờ các bạn giúp lấy số liệu bằng VBA. Cách lấy số lượng cột F như sau: số lượng sản phẩm sản xuất theo từng tháng * định mức nguyên vật liệu của từng sản phẩm. Trong file đính kèm, mình đã mô tả chi tiết và kết quả mẫu cần lấy. Chân thành cảm ơn các bạn.

 

[Ba Tê]

Chào các bạn,
Trong file đính kèm, ở cột F sheet NXT, mình muốn nhờ các bạn giúp lấy số liệu bằng VBA. Cách lấy số lượng cột F như sau: số lượng sản phẩm sản xuất theo từng tháng * định mức nguyên vật liệu của từng sản phẩm. Trong file đính kèm, mình đã mô tả chi tiết và kết quả mẫu cần lấy. Chân thành cảm ơn các bạn.

Bạn thử Sub này coi thế nào.

Public Sub s_Gpe()
Dim Dic As Object, sArr(), dArr(), KHSX(), DinhMuc()
Dim I As Long, R As Long, Txt1 As String, Txt2 As String
Set Dic = CreateObject("Scripting.Dictionary")
'--------------------------------------------------'
    KHSX = Sheets("Kehoach-sx").Range("A6", Sheets("Kehoach-sx").Range("A10000").End(xlUp)).Resize(, 13).Value
    For I = 1 To UBound(KHSX)
        Dic.Item(KHSX(I, 1)) = I
    Next I
'--------------------------------------------------'
    DinhMuc = Sheets("Dinhmuc").Range("A6", Sheets("Dinhmuc").Range("A10000").End(xlUp)).Resize(, 3).Value
    For I = 1 To UBound(DinhMuc)
        Dic.Item(DinhMuc(I, 1) & "#" & DinhMuc(I, 2)) = DinhMuc(I, 3)
    Next I
'--------------------------------------------------'
With Sheets("NXT")
    sArr = .Range("C9", .Range("C100000").End(xlUp)).Resize(, 3).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To R
        Txt1 = sArr(I, 2)
        Txt2 = sArr(I, 2) & "#" & sArr(I, 3)
        If Dic.Exists(Txt1) Then dArr(I, 1) = KHSX(Dic.Item(Txt1), sArr(I, 1) + 1)
        If Dic.Exists(Txt2) Then dArr(I, 1) = dArr(I, 1) * Dic.Item(Txt2)
    Next I
    .Range("G9").Resize(R) = dArr  'Gán vào cột nào đó'
End With
'--------------------------------------------------'
Set Dic = Nothing
End Sub

 

[thinhnx22]

Bạn thử Sub này coi thế nào.

Public Sub s_Gpe()
Dim Dic As Object, sArr(), dArr(), KHSX(), DinhMuc()
Dim I As Long, R As Long, Txt1 As String, Txt2 As String
Set Dic = CreateObject("Scripting.Dictionary")
'--------------------------------------------------'
    KHSX = Sheets("Kehoach-sx").Range("A6", Sheets("Kehoach-sx").Range("A10000").End(xlUp)).Resize(, 13).Value
    For I = 1 To UBound(KHSX)
        Dic.Item(KHSX(I, 1)) = I
    Next I
'--------------------------------------------------'
    DinhMuc = Sheets("Dinhmuc").Range("A6", Sheets("Dinhmuc").Range("A10000").End(xlUp)).Resize(, 3).Value
    For I = 1 To UBound(DinhMuc)
        Dic.Item(DinhMuc(I, 1) & "#" & DinhMuc(I, 2)) = DinhMuc(I, 3)
    Next I
'--------------------------------------------------'
With Sheets("NXT")
    sArr = .Range("C9", .Range("C100000").End(xlUp)).Resize(, 3).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To R
        Txt1 = sArr(I, 2)
        Txt2 = sArr(I, 2) & "#" & sArr(I, 3)
        If Dic.Exists(Txt1) Then dArr(I, 1) = KHSX(Dic.Item(Txt1), sArr(I, 1) + 1)
        If Dic.Exists(Txt2) Then dArr(I, 1) = dArr(I, 1) * Dic.Item(Txt2)
    Next I
    .Range("G9").Resize(R) = dArr  'Gán vào cột nào đó'
End With
'--------------------------------------------------'
Set Dic = Nothing
End Sub

Cảm ơn Bác Ba Tê rất nhiều, đã đúng yêu cầu của em rồi ạ. Chúc Bác một ngày vui.