Nhờ a/c cân đối số lượng thực tế và sổ sách

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

HUNGNGUYENCONG

Thành viên chính thức
Tham gia
18/7/19
Bài viết
54
Được thích
3
Nhờ anh chị gúp e viết công thức hoặc code VBA như file ví dụ e đã đính kèm.Em muốn cân đối số lượng cột F ,những mã hàng của cty này mà dư thì chuyển qua công ty khác để số lượng 2 cột D và F bằng nhau .số dư còn lại sẽ xuất bán lẻ sau.cảm ơn anh chị!
 

File đính kèm

Nhờ anh chị gúp e viết công thức hoặc code VBA như file ví dụ e đã đính kèm.Em muốn cân đối số lượng cột F ,những mã hàng của cty này mà dư thì chuyển qua công ty khác để số lượng 2 cột D và F bằng nhau .số dư còn lại sẽ xuất bán lẻ sau.cảm ơn anh chị!
Bạn cần nêu rõ quy tắc "cân kho" để người đọc hiểu được ý tưởng của bạn.

Số sổ sách so với thực tế thừa thì như thế nào, thiếu thì như thế nào.
Số nào làm là số chuẩn.
Hồi xưa mình làm kho, đôi khi có trường hợp xử lý cân kho xong thì phát hiện ra kiểm kê sai :))
 
Dạ ,số lượng Tồn kho thực tế em muốn lấy làm số chuẩn ,còn số lượng trên sổ sách dùng để xuất sang công ty còn thiếu theo mã hàng .sau khi cân đối xong ,số lượng còn dư trên sổ sách sẽ xuất bán lẻ
 
...
Hồi xưa mình làm kho, đôi khi có trường hợp xử lý cân kho xong thì phát hiện ra kiểm kê sai :))
Hiểm kê sai là vệc bình thường.
Vấn đề là Kế toán có quy trình để ghi phát sinh điều chỉnh hay chỉ mò chỉnh đại như thớt?
 
Nhờ anh chị gúp e viết công thức hoặc code VBA như file ví dụ e đã đính kèm.Em muốn cân đối số lượng cột F ,những mã hàng của cty này mà dư thì chuyển qua công ty khác để số lượng 2 cột D và F bằng nhau .số dư còn lại sẽ xuất bán lẻ sau.cảm ơn anh chị!
Kiểm tra lại kết quả
Mã:
Option Explicit
Sub DieuChinh()
  Dim sh As Worksheet, dic As Object, dic2 As Object
  Dim arr(), S, S2, res(), aDC()
  Dim sRow&, tRow&, i&, j&, r&, r2&, k&, SL#, tSL#, key
  Const srDC& = 1000 'Gioi han so dong hien thi ket qua dieu chinh, tang them neu can thiet
 
  ReDim aDC(1 To srDC, 1 To 4)
  Set sh = Sheet1
  arr = sh.Range("A3:G" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 1)
  Set dic = CreateObject("scripting.dictionary") 'Dieu chinh giam
  Set dic2 = CreateObject("scripting.dictionary") 'Dieu chinh tang
  For i = 1 To sRow
    res(i, 1) = arr(i, 6)
    arr(i, 1) = arr(i, 6) - arr(i, 4)
    If arr(i, 1) > 0 Then
      dic(arr(i, 3)) = dic(arr(i, 3)) & "," & i 'Dieu chinh giam
    ElseIf arr(i, 1) < 0 Then
      dic2(arr(i, 3)) = dic2(arr(i, 3)) & "," & i 'Dieu chinh tang
      arr(i, 1) = -arr(i, 1)
    End If
  Next i
  For Each key In dic.keys
    S = Split(dic(key), ",")
    S2 = Split(dic2(key), ",")
    For i = 1 To UBound(S)
      r = CLng(S(i))
      SL = arr(r, 1)
      For j = 1 To UBound(S2)
        r2 = CLng(S2(j))
        If arr(r2, 1) > 0 Then
          If arr(r2, 1) >= SL Then
            res(r, 1) = res(r, 1) - SL
            res(r2, 1) = res(r2, 1) + SL
            tSL = SL
            arr(r2, 1) = arr(r2, 1) - SL
            SL = 0
          Else
            res(r, 1) = res(r, 1) - arr(r2, 1)
            res(r2, 1) = res(r2, 1) + arr(r2, 1)
            tSL = arr(r2, 1)
            SL = SL - arr(r2, 1)
            arr(r2, 1) = 0
          End If
          k = k + 1
          If k <= srDC Then
            aDC(k, 1) = key
            aDC(k, 2) = arr(r, 2)
            aDC(k, 3) = arr(r2, 2)
            aDC(k, 4) = tSL
          End If
        End If
        If SL = 0 Then Exit For
      Next j
    Next i
  Next key
  sh.Range("I3").Resize(sRow) = res
  i = sh.Range("K" & Rows.Count).End(xlUp).Row
  If i > 2 Then sh.Range("K3:N" & i).ClearContents
  If k Then sh.Range("K3").Resize(k, 4) = aDC
End Sub
 

File đính kèm

Hiểm kê sai là vệc bình thường.
Vấn đề là Kế toán có quy trình để ghi phát sinh điều chỉnh hay chỉ mò chỉnh đại như thớt?
Dạ có quy trình a ạ ,nhưng do 1 số lý do nên dữ liệu bị thiếu nên phải dùng đến excel .
Bài đã được tự động gộp:

Kiểm tra lại kết quả
Mã:
Option Explicit
Sub DieuChinh()
  Dim sh As Worksheet, dic As Object, dic2 As Object
  Dim arr(), S, S2, res(), aDC()
  Dim sRow&, tRow&, i&, j&, r&, r2&, k&, SL#, tSL#, key
  Const srDC& = 1000 'Gioi han so dong hien thi ket qua dieu chinh, tang them neu can thiet
 
  ReDim aDC(1 To srDC, 1 To 4)
  Set sh = Sheet1
  arr = sh.Range("A3:G" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 1)
  Set dic = CreateObject("scripting.dictionary") 'Dieu chinh giam
  Set dic2 = CreateObject("scripting.dictionary") 'Dieu chinh tang
  For i = 1 To sRow
    res(i, 1) = arr(i, 6)
    arr(i, 1) = arr(i, 6) - arr(i, 4)
    If arr(i, 1) > 0 Then
      dic(arr(i, 3)) = dic(arr(i, 3)) & "," & i 'Dieu chinh giam
    ElseIf arr(i, 1) < 0 Then
      dic2(arr(i, 3)) = dic2(arr(i, 3)) & "," & i 'Dieu chinh tang
      arr(i, 1) = -arr(i, 1)
    End If
  Next i
  For Each key In dic.keys
    S = Split(dic(key), ",")
    S2 = Split(dic2(key), ",")
    For i = 1 To UBound(S)
      r = CLng(S(i))
      SL = arr(r, 1)
      For j = 1 To UBound(S2)
        r2 = CLng(S2(j))
        If arr(r2, 1) > 0 Then
          If arr(r2, 1) >= SL Then
            res(r, 1) = res(r, 1) - SL
            res(r2, 1) = res(r2, 1) + SL
            tSL = SL
            arr(r2, 1) = arr(r2, 1) - SL
            SL = 0
          Else
            res(r, 1) = res(r, 1) - arr(r2, 1)
            res(r2, 1) = res(r2, 1) + arr(r2, 1)
            tSL = arr(r2, 1)
            SL = SL - arr(r2, 1)
            arr(r2, 1) = 0
          End If
          k = k + 1
          If k <= srDC Then
            aDC(k, 1) = key
            aDC(k, 2) = arr(r, 2)
            aDC(k, 3) = arr(r2, 2)
            aDC(k, 4) = tSL
          End If
        End If
        If SL = 0 Then Exit For
      Next j
    Next i
  Next key
  sh.Range("I3").Resize(sRow) = res
  i = sh.Range("K" & Rows.Count).End(xlUp).Row
  If i > 2 Then sh.Range("K3:N" & i).ClearContents
  If k Then sh.Range("K3").Resize(k, 4) = aDC
End Sub
E

Kiểm tra lại kết quả
Mã:
Option Explicit
Sub DieuChinh()
  Dim sh As Worksheet, dic As Object, dic2 As Object
  Dim arr(), S, S2, res(), aDC()
  Dim sRow&, tRow&, i&, j&, r&, r2&, k&, SL#, tSL#, key
  Const srDC& = 1000 'Gioi han so dong hien thi ket qua dieu chinh, tang them neu can thiet
 
  ReDim aDC(1 To srDC, 1 To 4)
  Set sh = Sheet1
  arr = sh.Range("A3:G" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 1)
  Set dic = CreateObject("scripting.dictionary") 'Dieu chinh giam
  Set dic2 = CreateObject("scripting.dictionary") 'Dieu chinh tang
  For i = 1 To sRow
    res(i, 1) = arr(i, 6)
    arr(i, 1) = arr(i, 6) - arr(i, 4)
    If arr(i, 1) > 0 Then
      dic(arr(i, 3)) = dic(arr(i, 3)) & "," & i 'Dieu chinh giam
    ElseIf arr(i, 1) < 0 Then
      dic2(arr(i, 3)) = dic2(arr(i, 3)) & "," & i 'Dieu chinh tang
      arr(i, 1) = -arr(i, 1)
    End If
  Next i
  For Each key In dic.keys
    S = Split(dic(key), ",")
    S2 = Split(dic2(key), ",")
    For i = 1 To UBound(S)
      r = CLng(S(i))
      SL = arr(r, 1)
      For j = 1 To UBound(S2)
        r2 = CLng(S2(j))
        If arr(r2, 1) > 0 Then
          If arr(r2, 1) >= SL Then
            res(r, 1) = res(r, 1) - SL
            res(r2, 1) = res(r2, 1) + SL
            tSL = SL
            arr(r2, 1) = arr(r2, 1) - SL
            SL = 0
          Else
            res(r, 1) = res(r, 1) - arr(r2, 1)
            res(r2, 1) = res(r2, 1) + arr(r2, 1)
            tSL = arr(r2, 1)
            SL = SL - arr(r2, 1)
            arr(r2, 1) = 0
          End If
          k = k + 1
          If k <= srDC Then
            aDC(k, 1) = key
            aDC(k, 2) = arr(r, 2)
            aDC(k, 3) = arr(r2, 2)
            aDC(k, 4) = tSL
          End If
        End If
        If SL = 0 Then Exit For
      Next j
    Next i
  Next key
  sh.Range("I3").Resize(sRow) = res
  i = sh.Range("K" & Rows.Count).End(xlUp).Row
  If i > 2 Then sh.Range("K3:N" & i).ClearContents
  If k Then sh.Range("K3").Resize(k, 4) = aDC
End Sub
Dạ em cảm ơn anh .em đang kiểm tra lại ,thực sự code này quá kho với em.
 
Dạ có quy trình a ạ ,nhưng do 1 số lý do nên dữ liệu bị thiếu nên phải dùng đến excel .
Bài đã được tự động gộp:




Dạ em cảm ơn anh .em đang kiểm tra lại ,thực sự code này quá kho với em.
Khó không hiểu, thì tốt nhất tự làm và công thức đơn giản sẽ thuận lợi , và đảm bảo độ chính xác
 
Web KT

Bài viết mới nhất

Back
Top Bottom