CÔNG THỨC TỒN NHẬP XUẤT TỪ NGÀY ĐẾN NGÀY

Liên hệ QC

thanhtan19

Thành viên mới
Tham gia
4/11/15
Bài viết
13
Được thích
2
Giới tính
Nam
Gửi anh chị
Em có file NXT kho
nhưng nhập xuất tồn từ ngày đến ngày em không viết được
Mong anh chị giúp đỡ em VBA tổng hợp XNT trong sheet XNT được không ạ
em cám ơn anh chị
 

File đính kèm

  • Nhap xuat ton KHUON.xlsm
    784 KB · Đọc: 33
Gửi anh chị
Em có file NXT kho
nhưng nhập xuất tồn từ ngày đến ngày em không viết được
Mong anh chị giúp đỡ em VBA tổng hợp XNT trong sheet XNT được không ạ
em cám ơn anh chị
Chay code
Mã:
Option Explicit

Sub XYZ()
  Dim aDM(), aPS(), Res(), Dic As Object, ikey$
  Dim sRow&, i&, j&, k&, iR&, fDate, eDate

  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("N-X-T")
    fDate = .Range("A6").Value: eDate = .Range("A7").Value
  End With
  If fDate = Empty Then fDate = DateValue("1930/1/1")
  If eDate = Empty Then eDate = DateValue("2100/31/1")
  If TypeName(fDate) <> "Date" Or TypeName(eDate) <> "Date" Then
    MsgBox ("ô A6 hoac A7 Nhap Sai Dang Ngay Thang!"): Exit Sub
  End If
  If fDate > eDate Then
    MsgBox "Tu Ngày phai <= Den Ngày!": Exit Sub
  End If
 
  With Sheets("Danhmuc")
    aDM = .Range("B9:E" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("Nhaplieu")
    aPS = .Range("A11:H" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
 
  sRow = UBound(aDM)
  ReDim Res(1 To sRow + UBound(aPS), 1 To 7)
  For i = 1 To sRow
    ikey = aDM(i, 1)
    If Not Dic.exists(ikey) Then
      k = k + 1
      Dic.Add ikey, k
      Res(k, 1) = ikey: Res(k, 2) = aDM(i, 2): Res(k, 3) = aDM(i, 3)
    End If
    If aDM(i, 4) > 0 Then
      iR = Dic.Item(ikey)
      Res(iR, 4) = Res(iR, 4) + aDM(i, 4)
    End If
  Next i
 
  sRow = UBound(aPS)
  For i = 1 To sRow
    If aPS(i, 1) <= eDate Then
      ikey = aPS(i, 4)
      If Not Dic.exists(ikey) Then
        k = k + 1
        Dic.Add ikey, k
        Res(k, 1) = ikey: Res(k, 2) = aPS(i, 5): Res(k, 3) = aPS(i, 6)
      End If
      iR = Dic.Item(ikey)
      If aPS(i, 1) < fDate Then
        Res(iR, 4) = Res(iR, 4) + aPS(i, 7) - aPS(i, 8)
      Else
        If aPS(i, 8) = Empty Then
          Res(iR, 5) = Res(iR, 5) + aPS(i, 7)
        Else
          Res(iR, 6) = Res(iR, 6) + aPS(i, 8)
        End If
      End If
    End If
  Next i
 
  iR = 0
  For i = 1 To k
    For j = 4 To 6
      If Res(i, j) > 0 Then Exit For
    Next j
    If j <= 6 Then 'Loai bo cac dong khong Ton, Nhap va Xuat
      iR = iR + 1
      For j = 1 To 6
        Res(iR, j) = Res(i, j)
      Next j
      Res(iR, 7) = Res(iR, 4) + Res(iR, 5) - Res(iR, 6)
    End If
  Next i
 
  Application.ScreenUpdating = False
  With Sheets("N-X-T")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 10 Then Range("A11:G" & i).Clear
    If iR > 0 Then
      .Range("A11").Resize(iR).NumberFormat = "@"
      .Range("A11").Resize(iR, 7).Value = Res
      .Range("A11").Resize(iR, 7).Borders.LineStyle = 1
      .Range("A11").Resize(iR, 7).Sort .Range("A11"), 1
    End If
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Chay code
Mã:
Option Explicit

Sub XYZ()
  Dim aDM(), aPS(), Res(), Dic As Object, ikey$
  Dim sRow&, i&, j&, k&, iR&, fDate, eDate

  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("N-X-T")
    fDate = .Range("A6").Value: eDate = .Range("A7").Value
  End With
  If fDate = Empty Then fDate = DateValue("1930/1/1")
  If eDate = Empty Then eDate = DateValue("2100/31/1")
  If TypeName(fDate) <> "Date" Or TypeName(eDate) <> "Date" Then
    MsgBox ("ô A6 hoac A7 Nhap Sai Dang Ngay Thang!"): Exit Sub
  End If
  If fDate > eDate Then
    MsgBox "Tu Ngày phai <= Den Ngày!": Exit Sub
  End If

  With Sheets("Danhmuc")
    aDM = .Range("B9:E" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("Nhaplieu")
    aPS = .Range("A11:H" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With

  sRow = UBound(aDM)
  ReDim Res(1 To sRow + UBound(aPS), 1 To 7)
  For i = 1 To sRow
    ikey = aDM(i, 1)
    If Not Dic.exists(ikey) Then
      k = k + 1
      Dic.Add ikey, k
      Res(k, 1) = ikey: Res(k, 2) = aDM(i, 2): Res(k, 3) = aDM(i, 3)
    End If
    If aDM(i, 4) > 0 Then
      iR = Dic.Item(ikey)
      Res(iR, 4) = Res(iR, 4) + aDM(i, 4)
    End If
  Next i

  sRow = UBound(aPS)
  For i = 1 To sRow
    If aPS(i, 1) <= eDate Then
      ikey = aPS(i, 4)
      If Not Dic.exists(ikey) Then
        k = k + 1
        Dic.Add ikey, k
        Res(k, 1) = ikey: Res(k, 2) = aPS(i, 5): Res(k, 3) = aPS(i, 6)
      End If
      iR = Dic.Item(ikey)
      If aPS(i, 1) < fDate Then
        Res(iR, 4) = Res(iR, 4) + aPS(i, 7) - aPS(i, 8)
      Else
        If aPS(i, 8) = Empty Then
          Res(iR, 5) = Res(iR, 5) + aPS(i, 7)
        Else
          Res(iR, 6) = Res(iR, 6) + aPS(i, 8)
        End If
      End If
    End If
  Next i

  iR = 0
  For i = 1 To k
    For j = 4 To 6
      If Res(i, j) > 0 Then Exit For
    Next j
    If j <= 6 Then 'Loai bo cac dong khong Ton, Nhap va Xuat
      iR = iR + 1
      For j = 1 To 6
        Res(iR, j) = Res(i, j)
      Next j
      Res(iR, 7) = Res(iR, 4) + Res(iR, 5) - Res(iR, 6)
    End If
  Next i

  Application.ScreenUpdating = False
  With Sheets("N-X-T")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 10 Then Range("A11:G" & i).Clear
    If iR > 0 Then
      .Range("A11").Resize(iR).NumberFormat = "@"
      .Range("A11").Resize(iR, 7).Value = Res
      .Range("A11").Resize(iR, 7).Borders.LineStyle = 1
      .Range("A11").Resize(iR, 7).Sort .Range("A11"), 1
    End If
  End With
  Application.ScreenUpdating = True
End Sub
Dạ em xin phép được xin file hoàn chỉnh của chủ bài và của bác #HieuCD được không ạ. em cũng dán code vào để chạy thử mà không thấy nó chạy từ ngày đến ngày như mình chọn ạ. Em cảm ơn nhiều ạ !
 
Upvote 0

File đính kèm

  • Nhap xuat ton KHUON.xlsm
    799.6 KB · Đọc: 35
Upvote 0
Web KT
Back
Top Bottom