Nhờ giúp đỡ tạo báo cáo xuất theo fifo. (3 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
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

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

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

thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (4 người xem)
Trả lời
4
Đọc
58
ptm0412
ptm0412
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (1 người xem)
Trả lời
4
Đọc
150
VetMini
V
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (1 người xem)
Trả lời
16
Đọc
256
VetMini
V
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
22
Đọc
2K
gobi
gobi
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
112
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
346
Đọc
31K
Vandat1607
V
M
Xin giúp đỡ làm công thức điều kiện
Trả lời
2
Đọc
134
Hoangkhang01213
Hoangkhang01213
N
Khắc phục lỗi "The picture is too large and will be truncated" (1 người xem)
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
182
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
304
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
171
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
22
Đọc
582
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt (1 người xem)
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
149
lamvu0677
L
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (2 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
813
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
249
Hoàng Tuấn 868
H
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom