Giúp Theo dõi Xuất nhập hàng theo phương pháp FIFO

Liên hệ QC
HieuCD đã viết:
Ngày nhập và ngày xuất kho là ngày trên giấy tờ có thể không khớp với ngày nhập và xuất kho thực tế
Thủ kho muốn xuất thì trong kho phải có hàng, thời gian nhập kho thực tế chắc chắn trước thời gian xuất, tuy nhiên trên giấy tờ có thể vì lý do nào đó hàng đã nhập kho nhưng chưa làm phiếu nhập kho, sau đó mới bổ xung phiếu nhập kho sau và ngày nhập ghi theo thời gian lập phiếu nhập kho, do đó mình bỏ qua yếu tố thời gian
Nếu muốn chỉnh lại theo thời gian thì dùng code
Mã: 
Sub GPE2()
  Dim nhapArr(), xuatArr(), Res()
  Dim i As Long, n As Long, sRow As Long
  Dim sNhap As Double, sXuat As Double, dXuat As Date
  Dim Ma As String, tmp As String
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    nhapArr = .Range("A3:D" & i).Value
    i = .Range("F" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    xuatArr = .Range("F3:H" & i).Value
    sRow = UBound(xuatArr)
    ReDim Res(1 To sRow, 1 To 1)
  End With
  For i = 1 To sRow
    dXuat = xuatArr(i, 1): Ma = xuatArr(i, 2): sXuat = xuatArr(i, 3)
    tmp = ""
    If Len(Ma) > 0 And sXuat > 0 Then
      For n = 1 To UBound(nhapArr)
        If nhapArr(n, 1) > dXuat Then Exit For
        If nhapArr(n, 2) = Ma Then
          sNhap = nhapArr(n, 3)
          If sNhap > 0 Then
            If sNhap >= sXuat Then
              Res(i, 1) = tmp & nhapArr(n, 4)
              If Len(tmp) > 0 Then Res(i, 1) = Res(i, 1) & "(" & sXuat & ")"
              nhapArr(n, 3) = sNhap - sXuat
              sXuat = 0
              Exit For
            Else
              tmp = tmp & nhapArr(n, 4) & "(" & sNhap & "); "
              nhapArr(n, 3) = 0
              sXuat = sXuat - sNhap
            End If
          End If
        End If
      Next n
      If sXuat > 0 Then Res(i, 1) = tmp & "Thieu(" & sXuat & ")"
    End If
  Next i
  Sheets("Sheet1").Range("I3").Resize(sRow) = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Quá chuẩn , Thanks bác nhiệt tình
 
xin chào các anh chị,

em muốn hỏi cũng như chủ top về PP FIFO nhưng em muốn tìm lượng hàng còn lại trong kho là ở những ngày nhập nào bằng VBA
Nhờ các anh chị giúp ạ
 
Gấp gấp gấp
các anh chị ơi, giúp em với ạ
Em có file đầu tiên là tổng số lượng cần xuất
File thứ 2 là FIle tồn của PO, cột AZ là số lượng còn lại của các PO cần xuất
Ví dụ ngày 28 tháng 2 em cần xuất số lượng tổng ở file 1, thì em làm sao để có thể tự động lấy số lượng ở file 1 để bỏ vào cột ngày 28 và kiểm tra theo số tồn của PO. Note: PO nào có Due date , cột G tới trước thì xuất trước ạ.
Anh chị nào viết dc macro thì giúp em với ạ
Em cảm ơn rất nhiều
 
Chào các bạn,

Tôi thấy code của bạn rất hay, tôi muốn hỏi bạn có thể gíup nếu thêm vào 1 số điều kiện như sau:

1. Mã hàng : thêm mã phụ
2. Bảng tồn kho của mình có phần gọi là LOT ,có thể là
Ngày nhận hàng (YYYYMMDD)
Cụ thể không phải là ngày ( HCM, HN, DN, ...)
và cũng có thể không có
3. Số lô : thêm Kho (Kho1, Kho2 ...) rồi muốn tới số lô
Mặc định là Kho1, nhưng có thể tuỳ chọn Kho2,...

Mục đích là tạo ra phiếu xuất kho nhanh và gọn cho mình đi lấy hàng.

Cám ơn
 

File đính kèm

tle2003 đã viết:
Chào các bạn,

Tôi thấy code của bạn rất hay, tôi muốn hỏi bạn có thể gíup nếu thêm vào 1 số điều kiện như sau:

1. Mã hàng : thêm mã phụ
2. Bảng tồn kho của mình có phần gọi là LOT ,có thể là
Ngày nhận hàng (YYYYMMDD)
Cụ thể không phải là ngày ( HCM, HN, DN, ...)
và cũng có thể không có
3. Số lô : thêm Kho (Kho1, Kho2 ...) rồi muốn tới số lô
Mặc định là Kho1, nhưng có thể tuỳ chọn Kho2,...

Mục đích là tạo ra phiếu xuất kho nhanh và gọn cho mình đi lấy hàng.

Cám ơn
Nhấp chuột vào đây để mở rộng...
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
    
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
    
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
 

File đính kèm

File chạy tốt, cám ơn bạn.
Bạn có thể gíup thêm
1. Tại bảng hàng tồn kho : xoá dòng có số lượng bằng không.
2. Khi bấm nút xuất hàng thêm 1 động tác là lưu trữ dự liệu sang sheet Data có ngày (timestamp) để thêm dõi hàng xuất kho hàng ngày
Cám ơn bạn nhiều,
 
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
   
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
   
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With

  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...

Chào anh,
Em thấy code a viết tốt quá, tuy nhiên có thể thay đổi lại điều kiện này thì xử lý ntn ạ?
1595571338028.png
 

File đính kèm

  • 1595571324561.png
    1595571324561.png
    372.8 KB · Đọc: 17
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
 
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
 
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
 
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
 
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...

HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
  
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
  
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...
chào bạn
Bạn viết code hay quá, bạn có thể giúp mình viết code cho file xuất hàng và nhập FIFO với nhiều điều kiện
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
   
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
   
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
   
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
   
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...
Chào bạn

Bạn viết code hay quá, giúp
HieuCD đã viết:
FCode theo dữ liệu trong file
Mã: 
Sub PhieuXuat()
  Dim aTon(), aDDH(), Res()
  Dim i&, r&, r2&, k&, sRow&
  Dim sNhap#, sXuat#
  Dim Ma$, MaP$, Lot, Kho$, Ke&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 4 Then Range("T5:Z" & i).ClearContents 'Xóa du lieu
   
    i = .Range("L" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDDH = .Range("L5:P" & i).Value 'Don dat hang
   
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    Res = .Range("C5:H" & i).Value
    .Range("C5:H" & i).Sort .[C5], 1, .[H5], , 1, Header:=xlNo
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    .Range("C5:H" & i).Value = Res
  End With
  ReDim Res(1 To 50, 1 To 6)
  sRow = UBound(aDDH)
  For i = 1 To sRow
    Ma = aDDH(i, 1): MaP = aDDH(i, 2): Lot = aDDH(i, 3)
    Kho = aDDH(i, 4): sXuat = aDDH(i, 5)
    tmp = ""
    If Ma <> Empty Then
      For r = 1 To UBound(aTon)
        If aTon(r, 1) = Ma Then
          For r2 = r To UBound(aTon)
            If aTon(r2, 1) <> Ma Then Exit For '***
            sNhap = aTon(r2, 6)
            If sNhap > 0 Then
              If aTon(r2, 2) = MaP Or MaP = Empty Then
                If aTon(r2, 3) = Lot Or Lot = Empty Then
                  If aTon(r2, 4) = Kho Or Kho = Empty Then
                    k = k + 1
                    Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = aTon(r2, 3)
                    Res(k, 4) = Kho: Res(k, 5) = aTon(r2, 5)
                    If sNhap >= sXuat Then
                      Res(k, 6) = sXuat
                      sXuat = 0
                      Exit For '***
                    Else
                      Res(k, 6) = sNhap
                      sXuat = sXuat - sNhap
                    End If
                  End If
                End If
              End If
            End If
          Next r2
          If sXuat > 0 Then
            k = k + 1
            Res(k, 1) = Ma: Res(k, 2) = MaP: Res(k, 3) = Lot: Res(k, 4) = Kho
            Res(k, 6) = "Thieu " & sXuat
          End If
          Exit For '***
        End If
      Next r
    End If
  Next i
  Sheets("FIFO2").Range("T5").Resize(k, 6) = Res
End Sub

Sub XuatKho()
  Dim aTon(), aXuat(), Dic As Object, Ke$
  Dim i&, ik&, sRow&
  With Sheets("FIFO2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aXuat = .Range("T5:Y" & i).Value 'Phieu Xuat

    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    aTon = .Range("C5:H" & i).Value 'Hàng ton kho
    '.Range("T5:Y" & i).PrintPreview 'Xem trang in
    .Range("T5:Y" & i).PrintOut 'In Phieu xuat
    Range("T5:Z" & i).ClearContents 'Xóa du lieu
  End With
 
  'Giam hang ton kho
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTon)
  For i = 1 To sRow
    If aTon(i, 5) <> Empty Then Dic.Item(aTon(i, 5)) = i
  Next i
  sRow = UBound(aXuat)
  For i = 1 To sRow
    ik = Dic.Item(aXuat(i, 5))
    If ik > 0 Then
      aTon(ik, 6) = aTon(ik, 6) - aXuat(i, 6)
    End If
  Next i
  Sheets("FIFO2").Range("C5").Resize(UBound(aTon), 6) = aTon 'Giam hang ton kho
End Sub
Nhấp chuột vào đây để mở rộng...
Chào bạn

Mình thấy bạn rất giỏi, mình có thể thêm nhiều điều kiện trên phiếu xuất kho ( Bill , HĐ, TK, ngày nhập)
Và trừ lùi số lượng trên sheet total ( thường này mình làm tay dò từng mã mất khá nhiều thời gian )
Cám ơn bạn
 

File đính kèm

bluestart6789 đã viết:
chào bạn
Bạn viết code hay quá, bạn có thể giúp mình viết code cho file xuất hàng và nhập FIFO với nhiều điều kiện


Chào bạn

Bạn viết code hay quá, giúp

Chào bạn

Mình thấy bạn rất giỏi, mình có thể thêm nhiều điều kiện trên phiếu xuất kho ( Bill , HĐ, TK, ngày nhập)
Và trừ lùi số lượng trên sheet total ( thường này mình làm tay dò từng mã mất khá nhiều thời gian )
Cám ơn bạn
Nhấp chuột vào đây để mở rộng...
Code không khó, chỉ không biết sheet out ban đầu có gì, chay code ra kết quả như thế nào?
 

File đính kèm

bluestart6789 đã viết:
của mình cũng gần giống với bạn ở trên , minh có note lại thông tin
Nhờ bạn giúp dùm

cám ơn bạn
Nhấp chuột vào đây để mở rộng...
Gởi lại file thêm ví dụ của 2 tình huống:
1/ Nếu ( Bill , HD,TK, ngày nhập ) số lương không đủ sẽ lấy ( bill, HD,TK, ngày nhập) của lô kế tiếp
2/ Nếu không có sẽ báo thiếu và tô màu vàng
 
HieuCD đã viết:
Gởi lại file thêm ví dụ của 2 tình huống:
1/ Nếu ( Bill , HD,TK, ngày nhập ) số lương không đủ sẽ lấy ( bill, HD,TK, ngày nhập) của lô kế tiếp
2/ Nếu không có sẽ báo thiếu và tô màu vàng
Nhấp chuột vào đây để mở rộng...
mình gửi lại bạn file, mình có làm ví dụ 2 trường hợp
cám ơn bạn nha
 

File đính kèm

bluestart6789 đã viết:
mình gửi lại bạn file, mình có làm ví dụ 2 trường hợp
cám ơn bạn nha
Nhấp chuột vào đây để mở rộng...
Không được chen ngang dữ liệu lung tung
Kiểm tra lại code theo file đính kèm.
Mã: 
Option Explicit
Sub XYZ()
  Dim aNhap(), aTon#(), aDH(), aXuat(), res(), S, dic As Object
  Dim sRow&, sR&, i&, k&, r&, j&, iKey, sl#
 
  With Sheets("Total")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co Hang Nhap!"): Exit Sub
    aNhap = .Range("C3:I" & i).Value
    sRow = UBound(aNhap)
    ReDim aTon(1 To sRow, 1 To 2)
  End With
  With Sheets("out")
    i = .Range("G" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("G5:M" & i).ClearContents
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 6 Then MsgBox ("Khong co don hang!"): Exit Sub
    aDH = .Range("A6:B" & i).Value
  End With
  sR = UBound(aDH)
  ReDim aXuat(1 To sR * 3, 1 To 6)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sR
    iKey = aDH(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(aDH(i, 2))
    Else 'Gop code xuat kho giong nhau
      S = dic.Item(iKey)
      S(0) = S(0) + aDH(i, 2)
    End If
  Next i
  For i = 1 To sRow
    aTon(i, 2) = aNhap(i, 7)
    iKey = aNhap(i, 1)
    If dic.exists(iKey) = True Then
      S = dic.Item(iKey)
      If S(0) > 0 Then
        k = k + 1
        aXuat(k, 1) = iKey
        aXuat(k, 3) = aNhap(i, 3)
        aXuat(k, 4) = aNhap(i, 4)
        aXuat(k, 5) = aNhap(i, 5)
        aXuat(k, 6) = aNhap(i, 6)
        sl = S(0)
        If aTon(i, 2) >= sl Then
          aTon(i, 1) = aTon(i, 1) + sl
          aTon(i, 2) = aTon(i, 2) - sl
          aXuat(k, 2) = sl
          S(0) = 0
        Else
          aTon(i, 1) = aTon(i, 2)
          aTon(i, 2) = 0
          aXuat(k, 2) = aTon(i, 1)
          S(0) = sl - aXuat(k, 2)
        End If
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = k
        dic.Item(iKey) = S
      End If
    End If
  Next i
 
  Sheets("Total").Range("J3").Resize(sRow, 2) = aTon
  If k Then
    ReDim res(1 To k, 1 To 7)
    For Each iKey In dic.keys
      S = dic.Item(iKey)
      For i = 1 To UBound(S)
        r = r + 1
        For j = 1 To 6
          res(r, j) = aXuat(S(i), j)
        Next j
        If S(0) > 0 Then res(r, 7) = "Thieu " & S(0)
      Next i
    Next iKey
    Sheets("out").Range("G5").Resize(k, 7) = res
    Range("K5").Resize(k).NumberFormat = "#"
  End If
End Sub
 

File đính kèm

HieuCD đã viết:
Không được chen ngang dữ liệu lung tung
Kiểm tra lại code theo file đính kèm.
Mã: 
Option Explicit
Sub XYZ()
  Dim aNhap(), aTon#(), aDH(), aXuat(), res(), S, dic As Object
  Dim sRow&, sR&, i&, k&, r&, j&, iKey, sl#
 
  With Sheets("Total")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co Hang Nhap!"): Exit Sub
    aNhap = .Range("C3:I" & i).Value
    sRow = UBound(aNhap)
    ReDim aTon(1 To sRow, 1 To 2)
  End With
  With Sheets("out")
    i = .Range("G" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("G5:M" & i).ClearContents
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 6 Then MsgBox ("Khong co don hang!"): Exit Sub
    aDH = .Range("A6:B" & i).Value
  End With
  sR = UBound(aDH)
  ReDim aXuat(1 To sR * 3, 1 To 6)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sR
    iKey = aDH(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(aDH(i, 2))
    Else 'Gop code xuat kho giong nhau
      S = dic.Item(iKey)
      S(0) = S(0) + aDH(i, 2)
    End If
  Next i
  For i = 1 To sRow
    aTon(i, 2) = aNhap(i, 7)
    iKey = aNhap(i, 1)
    If dic.exists(iKey) = True Then
      S = dic.Item(iKey)
      If S(0) > 0 Then
        k = k + 1
        aXuat(k, 1) = iKey
        aXuat(k, 3) = aNhap(i, 3)
        aXuat(k, 4) = aNhap(i, 4)
        aXuat(k, 5) = aNhap(i, 5)
        aXuat(k, 6) = aNhap(i, 6)
        sl = S(0)
        If aTon(i, 2) >= sl Then
          aTon(i, 1) = aTon(i, 1) + sl
          aTon(i, 2) = aTon(i, 2) - sl
          aXuat(k, 2) = sl
          S(0) = 0
        Else
          aTon(i, 1) = aTon(i, 2)
          aTon(i, 2) = 0
          aXuat(k, 2) = aTon(i, 1)
          S(0) = sl - aXuat(k, 2)
        End If
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = k
        dic.Item(iKey) = S
      End If
    End If
  Next i
 
  Sheets("Total").Range("J3").Resize(sRow, 2) = aTon
  If k Then
    ReDim res(1 To k, 1 To 7)
    For Each iKey In dic.keys
      S = dic.Item(iKey)
      For i = 1 To UBound(S)
        r = r + 1
        For j = 1 To 6
          res(r, j) = aXuat(S(i), j)
        Next j
        If S(0) > 0 Then res(r, 7) = "Thieu " & S(0)
      Next i
    Next iKey
    Sheets("out").Range("G5").Resize(k, 7) = res
    Range("K5").Resize(k).NumberFormat = "#"
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
hi,bạn
file chạy mượt, bạn cho mình xin địa chỉ mail nha
Mình muốn inbox riêng bạn

cám ơn bạn
 
bluestart6789 đã viết:
Hi Bạn
Mình tính xin mail của bạn để gửi video quay màn hình cho bạn
* Tất cả mã đều bị luôn bạn
cám ơn bạn
Nhấp chuột vào đây để mở rộng...
Thiếu lệnh
dic.Item(iKey) = S
Mã: 
Sub XYZ()
  Dim aNhap(), aTon#(), aDH(), aXuat(), res(), S, dic As Object
  Dim sRow&, sR&, i&, k&, r&, j&, iKey, sl#
 
  With Sheets("Total")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co Hang Nhap!"): Exit Sub
    aNhap = .Range("C3:I" & i).Value
    sRow = UBound(aNhap)
    ReDim aTon(1 To sRow, 1 To 2)
  End With
  With Sheets("out") 'sl out
    i = .Range("G" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("G5:M" & i).ClearContents
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 6 Then MsgBox ("Khong co don hang!"): Exit Sub
    aDH = .Range("A6:B" & i).Value
  End With
  sR = UBound(aDH)
  ReDim aXuat(1 To sR * 3, 1 To 6)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sR
    iKey = aDH(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(aDH(i, 2))
    Else 'Gop code xuat kho giong nhau
      S = dic.Item(iKey)
      S(0) = S(0) + aDH(i, 2)
      dic.Item(iKey) = S
    End If
  Next i
  For i = 1 To sRow
    aTon(i, 2) = aNhap(i, 7)
    iKey = aNhap(i, 1)
    If dic.exists(iKey) = True Then
      S = dic.Item(iKey)
      If S(0) > 0 Then
        k = k + 1
        aXuat(k, 1) = iKey
        aXuat(k, 3) = aNhap(i, 3)
        aXuat(k, 4) = aNhap(i, 4)
        aXuat(k, 5) = aNhap(i, 5)
        aXuat(k, 6) = aNhap(i, 6)
        sl = S(0)
        If aTon(i, 2) >= sl Then
          aTon(i, 1) = aTon(i, 1) + sl
          aTon(i, 2) = aTon(i, 2) - sl
          aXuat(k, 2) = sl
          S(0) = 0
        Else
          aTon(i, 1) = aTon(i, 2)
          aTon(i, 2) = 0
          aXuat(k, 2) = aTon(i, 1)
          S(0) = sl - aXuat(k, 2)
        End If
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = k
        dic.Item(iKey) = S
      End If
    End If
  Next i
 
  Sheets("Total").Range("J3").Resize(sRow, 2) = aTon
  If k Then
    ReDim res(1 To k, 1 To 7)
    For Each iKey In dic.keys
      S = dic.Item(iKey)
      For i = 1 To UBound(S)
        r = r + 1
        For j = 1 To 6
          res(r, j) = aXuat(S(i), j)
        Next j
        If S(0) > 0 Then res(r, 7) = "Thieu " & S(0)
      Next i
    Next iKey
    Sheets("out").Range("G5").Resize(k, 7) = res
    Range("K5").Resize(k).NumberFormat = "#"
  End If
End Sub
 
HieuCD đã viết:
Thiếu lệnh
dic.Item(iKey) = S
Mã: 
Sub XYZ()
  Dim aNhap(), aTon#(), aDH(), aXuat(), res(), S, dic As Object
  Dim sRow&, sR&, i&, k&, r&, j&, iKey, sl#
 
  With Sheets("Total")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co Hang Nhap!"): Exit Sub
    aNhap = .Range("C3:I" & i).Value
    sRow = UBound(aNhap)
    ReDim aTon(1 To sRow, 1 To 2)
  End With
  With Sheets("out") 'sl out
    i = .Range("G" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("G5:M" & i).ClearContents
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 6 Then MsgBox ("Khong co don hang!"): Exit Sub
    aDH = .Range("A6:B" & i).Value
  End With
  sR = UBound(aDH)
  ReDim aXuat(1 To sR * 3, 1 To 6)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sR
    iKey = aDH(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(aDH(i, 2))
    Else 'Gop code xuat kho giong nhau
      S = dic.Item(iKey)
      S(0) = S(0) + aDH(i, 2)
      dic.Item(iKey) = S
    End If
  Next i
  For i = 1 To sRow
    aTon(i, 2) = aNhap(i, 7)
    iKey = aNhap(i, 1)
    If dic.exists(iKey) = True Then
      S = dic.Item(iKey)
      If S(0) > 0 Then
        k = k + 1
        aXuat(k, 1) = iKey
        aXuat(k, 3) = aNhap(i, 3)
        aXuat(k, 4) = aNhap(i, 4)
        aXuat(k, 5) = aNhap(i, 5)
        aXuat(k, 6) = aNhap(i, 6)
        sl = S(0)
        If aTon(i, 2) >= sl Then
          aTon(i, 1) = aTon(i, 1) + sl
          aTon(i, 2) = aTon(i, 2) - sl
          aXuat(k, 2) = sl
          S(0) = 0
        Else
          aTon(i, 1) = aTon(i, 2)
          aTon(i, 2) = 0
          aXuat(k, 2) = aTon(i, 1)
          S(0) = sl - aXuat(k, 2)
        End If
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = k
        dic.Item(iKey) = S
      End If
    End If
  Next i
 
  Sheets("Total").Range("J3").Resize(sRow, 2) = aTon
  If k Then
    ReDim res(1 To k, 1 To 7)
    For Each iKey In dic.keys
      S = dic.Item(iKey)
      For i = 1 To UBound(S)
        r = r + 1
        For j = 1 To 6
          res(r, j) = aXuat(S(i), j)
        Next j
        If S(0) > 0 Then res(r, 7) = "Thieu " & S(0)
      Next i
    Next iKey
    Sheets("out").Range("G5").Resize(k, 7) = res
    Range("K5").Resize(k).NumberFormat = "#"
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
vẫn bị giống vậy bạn ơi
Nhập 2 lệnh xuất, nhưng vẫn ghi nhận có 1 à bạn

cám ơn ban
 
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

V
Cho 2 biến - kết quả trả về giá trị của hàng đầu tiên
    • Chấp nhận
Trả lời
2
Đọc
36
SA_DQ
SA_DQ
D
Giúp đỡ thống kê dữ liệu theo điều kiện
Trả lời
8
Đọc
155
HieuCD
H
Mr.hieudoanxd
  • Question Question
[Cần hướng dẫn] Về lập trình Viết Function với Settimer và Killtimer
    • Thích
Trả lời
2
Đọc
124
Mr.hieudoanxd
Mr.hieudoanxd
bachloc1212
Đưa Text từ các dòng khác nhau về chung 1 dòng
Trả lời
10
Đọc
191
VetMini
V
N
Sửa lỗi code vba khi chạy cho ra kết quả không đúng
Trả lời
6
Đọc
139
VetMini
V
Ha Manh-LD
  • Question Question
Lấy dữ liệu từ file csv
Trả lời
1
Đọc
96
ptm0412
ptm0412
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
2
Đọc
108
VetMini
V
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
13
Đọc
405
LuuAnh980
LuuAnh980
HeSanbi
  • Đã giải quyết
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
9
Đọc
844
HeSanbi
HeSanbi
Tienvinh191
  • Question Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
28
Đọc
2K
quyenpv
quyenpv
F
Hiển thị text trong Gantt chart (Google sheets)
Trả lời
0
Đọc
48
FATA11
F
Maika8008
  • Đã giải quyết
[Chia sẻ] Dùng VBA trộn dữ liệu Excel sang file Word mẫu (tương tự chức năng Mail Merge)
    • Thích
    • Yêu thích
    • Cảm ơn
25 26 27
Trả lời
522
Đọc
50K
Manhhung90
Manhhung90
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
5
Đọc
213
VetMini
V
C
  • Question Question
import data từ excel lên google sheet
Trả lời
5
Đọc
618
SonBDND
S
ptm0412
Chúc mừng năm mới Ất Tỵ 2025
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
1
Đọc
143
ptm0412
ptm0412
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
2
Đọc
956
thopd
T
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
2
Đọc
128
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
14 15 16
Trả lời
307
Đọc
22K
kunkoi9390
K
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
6
Đọc
2K
tranhungdao12a3
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
45
Đọc
14K
ngocthu90
ngocthu90
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom