Trợ giúp cách thống kê nguyên vật liệu sử dụng để tạo ra thành phẩm B và thành phẩm B tạo ra từ nhiều bán thành phẩm trung gian A.

[thehailong]

Để tạo ra 1 thành phẩm e cần dùng một số nguyên vật liệu và bán thành phẩm.
Nhưng yêu cầu báo cáo phải chi tiêt số lượng nguyên vật liệu chứ ko phải bán thành phẩn.
Có ai giúp em ý tưởng chuyển data gốc sang sheet báo cáo với số lượng NVL ở cột D một cách tự động với,
E cám ơn

 

[thehailong]

Góp ý cho bạn:
1/ Theo tôi thì nên có 1 sheet danh mục sản phẩm, liệt kê mỗi loại sản phẩm (thành phẩm) gồm có những nguyên phụ liệu nào, (bán thành phẩm) gồm có những nguyên phụ liệu nào.
2/ Nhìn dữ liệu của bạn cũng không thực tế nên chẳng ai hiểu?

Cái bác cần chỉ cần dùng pivot table là có luôn mà. e đính kèm bác xem

 

[HieuCD]

Các bác ơi. Data thực tế của e nó như thế này. giờ phải xây dựng định mức chi tiết tới từng mã Nguyên vật liệu ạ
Mọi người giúp e với

Xem lại có trường hợp xuất A sản xuất B và xuất B sản xuất A không?
Code chạy không xét trường hợp trên

Dim Dic As Object, sArr(), sRow As Long, nuaTP As Boolean
Sub GPE()
  Dim i As Long, k As Long
  Dim Res()
  Dim iKey As Variant
  With Sheets("Data")
    sArr = .Range("B2", .Range("H1000000").End(xlUp)).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(1 To UBound(sArr, 1), 1 To 6)
  For i = 1 To UBound(sArr, 1)
    iKey = CStr(sArr(i, 1))
    Dic.Item(iKey) = Dic.Item(iKey) & "," & i
  Next i
  For i = 1 To UBound(sArr, 1)
    If IsNumeric(sArr(i, 3)) Then
      k = k + 1
      Res(k, 1) = sArr(i, 1)
      Res(k, 2) = sArr(i, 3)
      Res(k, 3) = CStr(sArr(i, 4))
      Res(k, 4) = Abs(sArr(i, 7))
     If Not Dic.exists(Res(k, 3)) Then Res(k, 5) = Res(k, 4)
    End If
  Next i
  sRow = k
  nuaTP = False
  Do While nuaTP = False
    Res = ThanhPham(Res)
  Loop
  Set Dic = Nothing
  Sheets("Ketqua").Range("A2").Resize(sRow, 5).Value = Res
End Sub
Private Function ThanhPham(ByVal dArr As Variant) As Variant
  Dim i As Long, r As Long, k As Long, ik As Long, j As Byte
  Dim Res(), S, SL, iKey
  ReDim Res(1 To sRow * 2, 1 To 6)
  nuaTP = True
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 5
      Res(k, j) = dArr(i, j)
    Next j
    iKey = CStr(Res(k, 3))
    If Dic.exists(iKey) Then
      If dArr(i, 6) = Empty Then
        Res(k, 5) = Empty: Res(k, 6) = True
        If dArr(i, 5) = Empty Then SL = dArr(i, 4) Else SL = dArr(i, 5)
        S = Split(Dic.Item(iKey), ",")
        For r = 1 To UBound(S)
          k = k + 1
          ik = CLng(S(r))
          Res(k, 1) = dArr(i, 1)
          Res(k, 2) = dArr(i, 2)
          Res(k, 3) = sArr(ik, 4)
          Res(k, 5) = SL * Abs(sArr(ik, 7)) / sArr(ik, 3)
          If Dic.exists(Res(k, 3)) Then nuaTP = False
        Next r
      End If
    End If
  Next i
  sRow = k
  ThanhPham = Res
End Function

 

[thehailong]

Xem lại có trường hợp xuất A sản xuất B và xuất B sản xuất A không?
Code chạy không xét trường hợp trên

Dim Dic As Object, sArr(), sRow As Long, nuaTP As Boolean
Sub GPE()
  Dim i As Long, k As Long
  Dim Res()
  Dim iKey As Variant
  With Sheets("Data")
    sArr = .Range("B2", .Range("H1000000").End(xlUp)).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(1 To UBound(sArr, 1), 1 To 6)
  For i = 1 To UBound(sArr, 1)
    iKey = CStr(sArr(i, 1))
    Dic.Item(iKey) = Dic.Item(iKey) & "," & i
  Next i
  For i = 1 To UBound(sArr, 1)
    If IsNumeric(sArr(i, 3)) Then
      k = k + 1
      Res(k, 1) = sArr(i, 1)
      Res(k, 2) = sArr(i, 3)
      Res(k, 3) = CStr(sArr(i, 4))
      Res(k, 4) = Abs(sArr(i, 7))
     If Not Dic.exists(Res(k, 3)) Then Res(k, 5) = Res(k, 4)
    End If
  Next i
  sRow = k
  nuaTP = False
  Do While nuaTP = False
    Res = ThanhPham(Res)
  Loop
  Set Dic = Nothing
  Sheets("Ketqua").Range("A2").Resize(sRow, 5).Value = Res
End Sub
Private Function ThanhPham(ByVal dArr As Variant) As Variant
  Dim i As Long, r As Long, k As Long, ik As Long, j As Byte
  Dim Res(), S, SL, iKey
  ReDim Res(1 To sRow * 2, 1 To 6)
  nuaTP = True
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 5
      Res(k, j) = dArr(i, j)
    Next j
    iKey = CStr(Res(k, 3))
    If Dic.exists(iKey) Then
      If dArr(i, 6) = Empty Then
        Res(k, 5) = Empty: Res(k, 6) = True
        If dArr(i, 5) = Empty Then SL = dArr(i, 4) Else SL = dArr(i, 5)
        S = Split(Dic.Item(iKey), ",")
        For r = 1 To UBound(S)
          k = k + 1
          ik = CLng(S(r))
          Res(k, 1) = dArr(i, 1)
          Res(k, 2) = dArr(i, 2)
          Res(k, 3) = sArr(ik, 4)
          Res(k, 5) = SL * Abs(sArr(ik, 7)) / sArr(ik, 3)
          If Dic.exists(Res(k, 3)) Then nuaTP = False
        Next r
      End If
    End If
  Next i
  sRow = k
  ThanhPham = Res
End Function

Cám ơn bác, e đã rà xoát data bỏ các trường hợp xuất A sản xuất B và xuất B sản xuất A nhưng vẫn ko work trên toàn bộ data. hic

 

[HieuCD]

Cám ơn bác, e đã rà xoát data bỏ các trường hợp xuất A sản xuất B và xuất B sản xuất A nhưng vẫn ko work trên toàn bộ data. hic

Code không chạy được khi tính lòng vòng như: A -->B -->C .... -->A
Thay code mới dài dòng hơn do có bẩy lổi

Dim Dic As Object, sArr(), nuaTP As Boolean
Sub GPE()
  Dim i As Long, k As Long, m As Byte
  Dim Res(), iKey As Variant
  Const GioiHan As Byte = 10
 
  With Sheets("Data")
    sArr = .Range("B2", .Range("H1000000").End(xlUp)).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(1 To UBound(sArr, 1), 1 To 6)
  For i = 1 To UBound(sArr, 1)
    iKey = CStr(sArr(i, 1))
    Dic.Item(iKey) = Dic.Item(iKey) & "," & i
  Next i
  For i = 1 To UBound(sArr, 1)
    If IsNumeric(sArr(i, 3)) Then
      k = k + 1
      Res(k, 1) = sArr(i, 1)
      Res(k, 2) = sArr(i, 3)
      Res(k, 3) = CStr(sArr(i, 4))
      Res(k, 4) = Abs(sArr(i, 7))
     If Not Dic.exists(Res(k, 3)) Then Res(k, 5) = Res(k, 4)
    End If
  Next i
  nuaTP = False
  Do While nuaTP = False
    m = m + 1
    If m = GioiHan Then MsgBox ("Tính lòng vòng quá tròi, No GoodBy!"): Exit Sub
    Res = ThanhPham(Res, k)
    k = UBound(Res, 1)
    
  Loop
  Set Dic = Nothing
  Sheets("KetQua").Range("A2").Resize(k, 5).Value = Res
End Sub
Private Function ThanhPham(ByVal dArr As Variant, ByVal sRow As Long) As Variant
  Dim i As Long, r As Long, k As Long, ik As Long, j As Byte
  Dim Res(), S, SL, iKey
  For i = 1 To sRow
    iKey = CStr(dArr(i, 3))
    If Dic.exists(iKey) Then
      If dArr(i, 6) = Empty Then
        S = Split(Dic.Item(iKey), ",")
        k = k + UBound(S)
      End If
    End If
  Next i
  ReDim Res(1 To sRow + k, 1 To 6)
  nuaTP = True
  k = 0
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 5
      Res(k, j) = dArr(i, j)
    Next j
    iKey = CStr(Res(k, 3))
    If Dic.exists(iKey) Then
      If dArr(i, 6) = Empty Then
        Res(k, 5) = Empty: Res(k, 6) = True
        If dArr(i, 5) = Empty Then SL = dArr(i, 4) Else SL = dArr(i, 5)
        S = Split(Dic.Item(iKey), ",")
        For r = 1 To UBound(S)
          k = k + 1
          ik = CLng(S(r))
          Res(k, 1) = dArr(i, 1)
          Res(k, 2) = dArr(i, 2)
          Res(k, 3) = sArr(ik, 4)
          Res(k, 5) = SL * Abs(sArr(ik, 7)) / sArr(ik, 3)
          If Dic.exists(Res(k, 3)) Then nuaTP = False
        Next r
      End If
    End If
  Next i
  ThanhPham = Res
End Function

Nếu có danh sách tính vòng, dùng hệ phương trình bậc 1 loại tính vòng sau đó mới chạy code trên