Nhờ giúp đỡ tạo báo cáo xuất theo fifo.

Liên hệ QC
P

Pi-Pikachu

Thành viên chính thức
Tham gia
22/2/21
Bài viết
71
Được thích
22
Chào các bạn,hiện mình đang gặp vấn đề tạo báo cáo xuất theo fifo mà chưa làm được.
1656497042858.png
Xin phép được đưa lên nhờ các bạn xem và giúp đỡ,
Cảm ơn các bạn nhiều.
 

File đính kèm

  • FIFO_.xlsx
    12.5 KB · Đọc: 29
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Upvote 0
Pi-Pikachu đã viết:
Dạ, file thực thì bảng dữ liệu không được sort theo mã hàng và cũng không được sort theo ngày thầy ạ.
Nhấp chuột vào đây để mở rộng...
Kiểm tra lại . . .
Mã: 
Option Explicit
Sub FiFo()
  Dim aDL(), aXuat(), arr$(), S, res(), sh As Worksheet, dic As Object
  Dim eR&, sRow&, sCol&, srXuat&, r&, i&, j&, k&, ngay, sl#
  Set dic = CreateObject("scripting.dictionary")
  Set sh = Sheets("FIFO")
  ngay = sh.Range("I4").Value
  eR = sh.Range("G1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  aXuat = sh.Range("G6:I" & eR).Value
  srXuat = UBound(aXuat)
 
  eR = sh.Range("B1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  Call DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
 
  ReDim res(1 To sRow + UBound(aXuat), 1 To 5)
  For i = 1 To srXuat
    k = k + 1
    For j = 1 To 3
      res(k, j) = aXuat(i, j)
    Next j
    If dic.exists(CStr(aXuat(i, 2))) Then
      sl = res(k, 3)
      S = dic(CStr(aXuat(i, 2)))
      For r = S(0) To S(1)
        If aDL(r, sCol) > 0 Then
          k = k + 1
          res(k, 4) = aDL(r, 3)
          If sl > aDL(r, sCol) Then
            sl = sl - aDL(r, sCol)
            res(k, 3) = aDL(r, sCol)
            res(k, 5) = 0
            aDL(r, sCol) = 0
          Else
            res(k, 3) = sl
            aDL(r, sCol) = aDL(r, sCol) - sl
            res(k, 5) = aDL(r, sCol)
            Exit For
          End If
        End If
      Next r
    End If
  Next i
  eR = sh.Range("M1048000").End(xlUp).Row
  If eR > 5 Then sh.Range("K6:O" & eR).ClearContents
  sh.Range("M4").Value = ngay
  If k Then
    sh.Range("L6").Resize(k).NumberFormat = "@"
    sh.Range("K6").Resize(k, 5) = res
  End If
End Sub

Private Sub DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
  Dim arr(), arrText$(), i&, r&, fR&, mh$, sl#

  arr = sh.Range("B6:E" & eR).Value
  sRow = UBound(arr)
  ReDim arrText(1 To sRow, 1 To 1)
  For i = 1 To sRow
    arrText(i, 1) = CStr(arr(i, 1))
  Next i
  sh.Range("B6:E" & eR).Sort sh.Range("B6"), 1, sh.Range("D6"), , 1, sh.Range("C6"), 1, Header:=xlNo
  aDL = sh.Range("B6:E" & eR + 1).Value
  sh.Range("B6:E" & eR).Value = arr
  sh.Range("B6:B" & eR).Value = arrText
  Erase arr: Erase arrText
 
  sCol = UBound(aDL, 2)
  For i = 1 To sRow
    If mh <> aDL(i, 1) Then
      fR = i: eR = 0
      mh = aDL(i, 1)
    End If
    If aDL(i, 3) <= ngay Then
      If aDL(i, 2) = "X" Then
        For r = fR To i - 1
          If aDL(r, 2) = "N" Then
            If aDL(i, sCol) <= aDL(r, sCol) Then
              aDL(r, sCol) = aDL(r, sCol) - aDL(i, sCol)
              aDL(i, sCol) = 0
              fR = r
              Exit For
            Else
              aDL(i, sCol) = aDL(i, sCol) - aDL(r, sCol)
              aDL(r, sCol) = 0
            End If
          End If
        Next r
      End If
      If aDL(i, 2) = "N" Then
        eR = i
        If eR >= fR Then dic(mh) = Array(fR, eR)
      End If
    End If
  Next i
End Sub
 
Upvote 0
HieuCD đã viết:
Kiểm tra lại . . .
Mã: 
Option Explicit
Sub FiFo()
  Dim aDL(), aXuat(), arr$(), S, res(), sh As Worksheet, dic As Object
  Dim eR&, sRow&, sCol&, srXuat&, r&, i&, j&, k&, ngay, sl#
  Set dic = CreateObject("scripting.dictionary")
  Set sh = Sheets("FIFO")
  ngay = sh.Range("I4").Value
  eR = sh.Range("G1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  aXuat = sh.Range("G6:I" & eR).Value
  srXuat = UBound(aXuat)
 
  eR = sh.Range("B1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  Call DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
 
  ReDim res(1 To sRow + UBound(aXuat), 1 To 5)
  For i = 1 To srXuat
    k = k + 1
    For j = 1 To 3
      res(k, j) = aXuat(i, j)
    Next j
    If dic.exists(CStr(aXuat(i, 2))) Then
      sl = res(k, 3)
      S = dic(CStr(aXuat(i, 2)))
      For r = S(0) To S(1)
        If aDL(r, sCol) > 0 Then
          k = k + 1
          res(k, 4) = aDL(r, 3)
          If sl > aDL(r, sCol) Then
            sl = sl - aDL(r, sCol)
            res(k, 3) = aDL(r, sCol)
            res(k, 5) = 0
            aDL(r, sCol) = 0
          Else
            res(k, 3) = sl
            aDL(r, sCol) = aDL(r, sCol) - sl
            res(k, 5) = aDL(r, sCol)
            Exit For
          End If
        End If
      Next r
    End If
  Next i
  eR = sh.Range("M1048000").End(xlUp).Row
  If eR > 5 Then sh.Range("K6:O" & eR).ClearContents
  sh.Range("M4").Value = ngay
  If k Then
    sh.Range("L6").Resize(k).NumberFormat = "@"
    sh.Range("K6").Resize(k, 5) = res
  End If
End Sub

Private Sub DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
  Dim arr(), arrText$(), i&, r&, fR&, mh$, sl#

  arr = sh.Range("B6:E" & eR).Value
  sRow = UBound(arr)
  ReDim arrText(1 To sRow, 1 To 1)
  For i = 1 To sRow
    arrText(i, 1) = CStr(arr(i, 1))
  Next i
  sh.Range("B6:E" & eR).Sort sh.Range("B6"), 1, sh.Range("D6"), , 1, sh.Range("C6"), 1, Header:=xlNo
  aDL = sh.Range("B6:E" & eR + 1).Value
  sh.Range("B6:E" & eR).Value = arr
  sh.Range("B6:B" & eR).Value = arrText
  Erase arr: Erase arrText
 
  sCol = UBound(aDL, 2)
  For i = 1 To sRow
    If mh <> aDL(i, 1) Then
      fR = i: eR = 0
      mh = aDL(i, 1)
    End If
    If aDL(i, 3) <= ngay Then
      If aDL(i, 2) = "X" Then
        For r = fR To i - 1
          If aDL(r, 2) = "N" Then
            If aDL(i, sCol) <= aDL(r, sCol) Then
              aDL(r, sCol) = aDL(r, sCol) - aDL(i, sCol)
              aDL(i, sCol) = 0
              fR = r
              Exit For
            Else
              aDL(i, sCol) = aDL(i, sCol) - aDL(r, sCol)
              aDL(r, sCol) = 0
            End If
          End If
        Next r
      End If
      If aDL(i, 2) = "N" Then
        eR = i
        If eR >= fR Then dic(mh) = Array(fR, eR)
      End If
    End If
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Thầy ơi, cảm ơn thầy lắm lắm,
Code khủng khiếp quá, kết quả đúng như ý em muốn rồi, nhanh quá thầy ơi, tiết kiệm được nhiều thời gian lắm thầy ạ.
Thầy ơi nhờ thầy chỉnh thêm giúp em 2 trường hợp ở bảng kết quả, nếu nhập cùng ngày thì gộp vào một dòng và nếu số lượng xuất không đủ thì hiển thị số lượng phần còn thiếu trong cột ghi chú với ạ, em có mô tả thêm trong file kèm ạ.
 

File đính kèm

  • FIFO_2.xlsm
    24.6 KB · Đọc: 61
Upvote 0
Pi-Pikachu đã viết:
Thầy ơi, cảm ơn thầy lắm lắm,
Code khủng khiếp quá, kết quả đúng như ý em muốn rồi, nhanh quá thầy ơi, tiết kiệm được nhiều thời gian lắm thầy ạ.
Thầy ơi nhờ thầy chỉnh thêm giúp em 2 trường hợp ở bảng kết quả, nếu nhập cùng ngày thì gộp vào một dòng và nếu số lượng xuất không đủ thì hiển thị số lượng phần còn thiếu trong cột ghi chú với ạ, em có mô tả thêm trong file kèm ạ.
Nhấp chuột vào đây để mở rộng...
Chỉnh lại . . .
Mã: 
Option Explicit
Sub FiFo()
  Dim aDL(), aXuat(), arr$(), S, res(), sh As Worksheet, dic As Object
  Dim eR&, sRow&, sCol&, srXuat&, r&, r2&, i&, j&, k&, ik&, ngay, sl#, slN#
  Set dic = CreateObject("scripting.dictionary")
  Set sh = Sheets("FIFO")
  ngay = sh.Range("I4").Value
  eR = sh.Range("G1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  aXuat = sh.Range("G6:I" & eR).Value
  srXuat = UBound(aXuat)
 
  eR = sh.Range("B1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  Call DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
 
  ReDim res(1 To sRow + UBound(aXuat), 1 To 6)
  For i = 1 To srXuat
    k = k + 1: ik = k
    For j = 1 To 3
      res(k, j) = aXuat(i, j)
    Next j
    sl = res(k, 3)
    If dic.exists(CStr(aXuat(i, 2))) Then
      S = dic(CStr(aXuat(i, 2)))
      For r = S(0) To S(1)
        If aDL(r, sCol) > 0 Then
          For r2 = r + 1 To S(1)
            If aDL(r2, 3) = aDL(r2 - 1, 3) Then
              aDL(r2, 4) = aDL(r2, 4) + aDL(r2 - 1, 4)
            Else
              Exit For
            End If
          Next r2
          r = r2 - 1
          k = k + 1
          res(k, 4) = aDL(r, 3)
          If sl > aDL(r, sCol) Then
            sl = sl - aDL(r, sCol)
            res(k, 3) = aDL(r, sCol)
            res(k, 5) = 0
            aDL(r, sCol) = 0
          Else
            res(k, 3) = sl
            aDL(r, sCol) = aDL(r, sCol) - sl
            res(k, 5) = aDL(r, sCol)
            sl = 0
            Exit For
          End If
          
        End If
      Next r
    End If
    res(ik, 6) = -sl
  Next i
  eR = sh.Range("M1048000").End(xlUp).Row
  If eR > 5 Then sh.Range("K6:O" & eR).ClearContents
  sh.Range("M4").Value = ngay
  If k Then
    sh.Range("L6").Resize(k).NumberFormat = "@"
    sh.Range("K6").Resize(k, 6) = res
  End If
End Sub

Private Sub DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
  Dim arr(), arrText$(), i&, r&, fR&, mh$, sl#

  arr = sh.Range("B6:E" & eR).Value
  sRow = UBound(arr)
  ReDim arrText(1 To sRow, 1 To 1)
  For i = 1 To sRow
    arrText(i, 1) = CStr(arr(i, 1))
  Next i
  sh.Range("B6:E" & eR).Sort sh.Range("B6"), 1, sh.Range("D6"), , 1, sh.Range("C6"), 1, Header:=xlNo
  aDL = sh.Range("B6:E" & eR + 1).Value
  sh.Range("B6:E" & eR).Value = arr
  sh.Range("B6:B" & eR).Value = arrText
  Erase arr: Erase arrText
 
  sCol = UBound(aDL, 2)
  For i = 1 To sRow
    If mh <> aDL(i, 1) Then
      fR = i: eR = 0
      mh = aDL(i, 1)
    End If
    If aDL(i, 3) <= ngay Then
      If aDL(i, 2) = "X" Then
        For r = fR To i - 1
          If aDL(r, 2) = "N" Then
            If aDL(i, sCol) <= aDL(r, sCol) Then
              aDL(r, sCol) = aDL(r, sCol) - aDL(i, sCol)
              aDL(i, sCol) = 0
              fR = r
              Exit For
            Else
              aDL(i, sCol) = aDL(i, sCol) - aDL(r, sCol)
              aDL(r, sCol) = 0
            End If
          End If
        Next r
      End If
      If aDL(i, 2) = "N" Then
        eR = i
        If eR >= fR Then dic(mh) = Array(fR, eR)
      End If
    End If
  Next i
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại . . .
Mã: 
Option Explicit
Sub FiFo()
  Dim aDL(), aXuat(), arr$(), S, res(), sh As Worksheet, dic As Object
  Dim eR&, sRow&, sCol&, srXuat&, r&, r2&, i&, j&, k&, ik&, ngay, sl#, slN#
  Set dic = CreateObject("scripting.dictionary")
  Set sh = Sheets("FIFO")
  ngay = sh.Range("I4").Value
  eR = sh.Range("G1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  aXuat = sh.Range("G6:I" & eR).Value
  srXuat = UBound(aXuat)
 
  eR = sh.Range("B1048000").End(xlUp).Row
  If eR < 6 Then MsgBox ("Khong co du lieu!"): Exit Sub
  Call DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
 
  ReDim res(1 To sRow + UBound(aXuat), 1 To 6)
  For i = 1 To srXuat
    k = k + 1: ik = k
    For j = 1 To 3
      res(k, j) = aXuat(i, j)
    Next j
    sl = res(k, 3)
    If dic.exists(CStr(aXuat(i, 2))) Then
      S = dic(CStr(aXuat(i, 2)))
      For r = S(0) To S(1)
        If aDL(r, sCol) > 0 Then
          For r2 = r + 1 To S(1)
            If aDL(r2, 3) = aDL(r2 - 1, 3) Then
              aDL(r2, 4) = aDL(r2, 4) + aDL(r2 - 1, 4)
            Else
              Exit For
            End If
          Next r2
          r = r2 - 1
          k = k + 1
          res(k, 4) = aDL(r, 3)
          If sl > aDL(r, sCol) Then
            sl = sl - aDL(r, sCol)
            res(k, 3) = aDL(r, sCol)
            res(k, 5) = 0
            aDL(r, sCol) = 0
          Else
            res(k, 3) = sl
            aDL(r, sCol) = aDL(r, sCol) - sl
            res(k, 5) = aDL(r, sCol)
            sl = 0
            Exit For
          End If
         
        End If
      Next r
    End If
    res(ik, 6) = -sl
  Next i
  eR = sh.Range("M1048000").End(xlUp).Row
  If eR > 5 Then sh.Range("K6:O" & eR).ClearContents
  sh.Range("M4").Value = ngay
  If k Then
    sh.Range("L6").Resize(k).NumberFormat = "@"
    sh.Range("K6").Resize(k, 6) = res
  End If
End Sub

Private Sub DuLieu(aDL, dic, sh, eR, sRow, sCol, ngay)
  Dim arr(), arrText$(), i&, r&, fR&, mh$, sl#

  arr = sh.Range("B6:E" & eR).Value
  sRow = UBound(arr)
  ReDim arrText(1 To sRow, 1 To 1)
  For i = 1 To sRow
    arrText(i, 1) = CStr(arr(i, 1))
  Next i
  sh.Range("B6:E" & eR).Sort sh.Range("B6"), 1, sh.Range("D6"), , 1, sh.Range("C6"), 1, Header:=xlNo
  aDL = sh.Range("B6:E" & eR + 1).Value
  sh.Range("B6:E" & eR).Value = arr
  sh.Range("B6:B" & eR).Value = arrText
  Erase arr: Erase arrText
 
  sCol = UBound(aDL, 2)
  For i = 1 To sRow
    If mh <> aDL(i, 1) Then
      fR = i: eR = 0
      mh = aDL(i, 1)
    End If
    If aDL(i, 3) <= ngay Then
      If aDL(i, 2) = "X" Then
        For r = fR To i - 1
          If aDL(r, 2) = "N" Then
            If aDL(i, sCol) <= aDL(r, sCol) Then
              aDL(r, sCol) = aDL(r, sCol) - aDL(i, sCol)
              aDL(i, sCol) = 0
              fR = r
              Exit For
            Else
              aDL(i, sCol) = aDL(i, sCol) - aDL(r, sCol)
              aDL(r, sCol) = 0
            End If
          End If
        Next r
      End If
      If aDL(i, 2) = "N" Then
        eR = i
        If eR >= fR Then dic(mh) = Array(fR, eR)
      End If
    End If
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Vô cùng cảm ơn thầy,nhờ thầy mà công việc khó của em đã được giải quyết ạ.
 
Upvote 0
Pi-Pikachu đã viết:
Vô cùng cảm ơn thầy,nhờ thầy mà công việc khó của em đã được giải quyết ạ.
Nhấp chuột vào đây để mở rộng...
Hi bạn, file của bạn mình cũng thấy rất hay và có thể áp dụng được cho công việc của mình. Nhưng yêu cầu cấp trên đưa ra phải chỉ ra vị trí kệ hàng cất lô hàng đã nhập đó, mà mình thì lại không biết VBA, bạn có thể thêm cột vị trí vào cột F (nhập vào) và cột Q khi xuất ra không ạ?
Bài đã được tự động gộp:

1704246812441.png
 
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
  • Question
nhờ viết code chuyển file excel sang file mẫu .txt
Trả lời
2
Đọc
112
soap1234
S
H
Nhờ hướng dẫn chuyển hàng thành cột và dữ liệu theo nhu cầu bằng VBA
Trả lời
1
Đọc
55
DeTong
D
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
2
Đọc
73
SA_DQ
SA_DQ
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
2
Đọc
67
NguyenthiH
NguyenthiH
T
Cần giúp sao chép C1 từ B1
Trả lời
3
Đọc
84
tle2003
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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