HD viết code tạo giá xuất và tồn CK! (1 người xem)

[ThuNghi]

Tôi có file như sau, phần yêu cầu là những dữ liệu phía dưới. kết quả theo như ct phần trên, phần cells tô màu vàng.
1/ Các file NXT01, ..., NXT03 là những file nhập xuất tồn theo tháng 1, 2, 3.
2/ Làm sao lấy giá xuất bình quân gán vào sh.
3/ Lấy tồn CK của XNT01 là tồn DK của XNT02. Và tiếp tục gán giá xuất => tồn CK.
Nhờ các bạn viết giúp code để giảm bớt những ct sumif...
Xin cám ơn.

 

[huuthang_bd]

Tôi có file như sau, phần yêu cầu là những dữ liệu phía dưới. kết quả theo như ct phần trên, phần cells tô màu vàng.
1/ Các file NXT01, ..., NXT03 là những file nhập xuất tồn theo tháng 1, 2, 3.
2/ Làm sao lấy giá xuất bình quân gán vào sh.
3/ Lấy tồn CK của XNT01 là tồn DK của XNT02. Và tiếp tục gán giá xuất => tồn CK.
Nhờ các bạn viết giúp code để giảm bớt những ct sumif...
Xin cám ơn.

Em xin phép múa rìu qua mắt thợ vậy.

Sub TinhGiaXK(Rng As Range)
Dim Arr, i As Long
Arr = Rng.Value
For i = 1 To UBound(Arr, 1)
    Arr(i, 9) = (Arr(i, 5) + Arr(i, 7)) / (Arr(i, 4) + Arr(i, 6)) * Arr(i, 8)
    Arr(i, 10) = Arr(i, 4) + Arr(i, 6) - Arr(i, 8)
    Arr(i, 11) = Arr(i, 5) + Arr(i, 7) - Arr(i, 9)
Next
Rng.Value = Arr
End Sub

Sub ChuyenSo(KyTruoc As Range, KySau As Range)
Dim Dic, Arr1, Arr2, i As Long, Tmp
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = KyTruoc.Value
For i = 1 To UBound(Arr1, 1)
    If Not Dic.Exists(Arr1(i, 2)) Then
        Dic.Add Arr1(i, 2), i
    End If
Next
Arr2 = KySau.Value
For i = 1 To UBound(Arr2, 1)
    If Dic.Exists(Arr2(i, 2)) Then
        Arr2(i, 4) = Arr1(Dic.Item(Arr2(i, 2)), 10)
        Arr2(i, 5) = Arr1(Dic.Item(Arr2(i, 2)), 11)
    End If
Next
KySau.Value = Arr2
End Sub

Sub Main()
Dim Rng1 As Range, Rng2 As Range, i As Long
Set Rng1 = Sheets("XNT01").Range(Sheets("XNT01").[K20], Sheets("XNT01").[B65536].End(xlUp).Offset(, -1))
Call TinhGiaXK(Rng1)
For i = 2 To 3
    Set Rng1 = Sheets("XNT" & Format(i - 1, "00")).Range(Sheets("XNT" & Format(i - 1, "00")).[K20], Sheets("XNT" & Format(i - 1, "00")).[B65536].End(xlUp).Offset(, -1))
    Set Rng2 = Sheets("XNT" & Format(i, "00")).Range(Sheets("XNT" & Format(i, "00")).[K20], Sheets("XNT" & Format(i, "00")).[B65536].End(xlUp).Offset(, -1))
    Call ChuyenSo(Rng1, Rng2)
    Call TinhGiaXK(Rng2)
Next
End Sub

 

[ThuNghi]

Em xin phép múa rìu qua mắt thợ vậy.

Sub TinhGiaXK(Rng As Range)
Dim Arr, i As Long
Arr = Rng.Value
For i = 1 To UBound(Arr, 1)
    Arr(i, 9) = (Arr(i, 5) + Arr(i, 7)) / (Arr(i, 4) + Arr(i, 6)) * Arr(i, 8)
    Arr(i, 10) = Arr(i, 4) + Arr(i, 6) - Arr(i, 8)
    Arr(i, 11) = Arr(i, 5) + Arr(i, 7) - Arr(i, 9)
Next
Rng.Value = Arr
End Sub

Sub ChuyenSo(KyTruoc As Range, KySau As Range)
Dim Dic, Arr1, Arr2, i As Long, Tmp
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = KyTruoc.Value
For i = 1 To UBound(Arr1, 1)
    If Not Dic.Exists(Arr1(i, 2)) Then
        Dic.Add Arr1(i, 2), i
    End If
Next
Arr2 = KySau.Value
For i = 1 To UBound(Arr2, 1)
    If Dic.Exists(Arr2(i, 2)) Then
        Arr2(i, 4) = Arr1(Dic.Item(Arr2(i, 2)), 10)
        Arr2(i, 5) = Arr1(Dic.Item(Arr2(i, 2)), 11)
    End If
Next
KySau.Value = Arr2
End Sub

Sub Main()
Dim Rng1 As Range, Rng2 As Range, i As Long
Set Rng1 = Sheets("XNT01").Range(Sheets("XNT01").[K20], Sheets("XNT01").[B65536].End(xlUp).Offset(, -1))
Call TinhGiaXK(Rng1)
For i = 2 To 3
    Set Rng1 = Sheets("XNT" & Format(i - 1, "00")).Range(Sheets("XNT" & Format(i - 1, "00")).[K20], Sheets("XNT" & Format(i - 1, "00")).[B65536].End(xlUp).Offset(, -1))
    Set Rng2 = Sheets("XNT" & Format(i, "00")).Range(Sheets("XNT" & Format(i, "00")).[K20], Sheets("XNT" & Format(i, "00")).[B65536].End(xlUp).Offset(, -1))
    Call ChuyenSo(Rng1, Rng2)
    Call TinhGiaXK(Rng2)
Next
End Sub

Rất cám ơn Thắng, nếu chưa có code trên thì a cứng lòng vòng chả biết làm phần nào trước.

 

[ThuNghi]

Tiện đây nhờ Thắng và các bạn làm giúp code để tạp phần màu vàng gồm GT nhập, SL và GT xuất, SL và GT tồn đầu và cuối trong sh XNT_TH.
Dữ liệu gồm sh
1/ CTNhap
2/ CTXuat
3/ TonDK (CK năm trước)
Xuất bình quân.
Xin cám ơn. Mục đích: cần điều chỉnh giá nhập thì lấy giá xuất kịp thời.

 

[ThuNghi]

Bổ sung thêm là data đã được sort.
Tính viết code là for iM=1 to 3 và làm và gán theo từng tháng 1 giống như là tách ra XNTmm, nhưng như vậy thấy dài dòng quá.
Nhờ các bạn tư duy giúp thuật toán.

 

[huuthang_bd]

Tiện đây nhờ Thắng và các bạn làm giúp code để tạp phần màu vàng gồm GT nhập, SL và GT xuất, SL và GT tồn đầu và cuối trong sh XNT_TH.
Dữ liệu gồm sh
1/ CTNhap
2/ CTXuat
3/ TonDK (CK năm trước)
Xuất bình quân.
Xin cám ơn. Mục đích: cần điều chỉnh giá nhập thì lấy giá xuất kịp thời.

Em làm như thế này. Code hơi dài.

Dim KetQua(), SoDong As Long, STT As Long, DSHH

Private Sub SDDK()
Dim ArrDK, i As Long, j As Long
Set DSHH = CreateObject("Scripting.Dictionary")
STT = 0
If Sheet3.[A3].Value <> "" Then
    ArrDK = Sheet3.Range(Sheet3.[E3], Sheet3.[A65536].End(xlUp))
    SoDong = UBound(ArrDK, 1)
    ReDim KetQua(1 To 12, 1 To SoDong)
    For i = 1 To SoDong
        KetQua(1, i) = 1
        STT = STT + 1
        KetQua(2, i) = STT
        For j = 1 To UBound(ArrDK, 2)
            KetQua(1 + j, i) = ArrDK(i, j)
        Next
        DSHH.Add KetQua(3, i), i
    Next
Erase ArrDK
End If
End Sub

Private Sub NXTThang(ByVal Thang As Long)
Dim ArrNhap, ArrXuat, FindCll1 As Range, FindCll2 As Range, i As Long, ViTri
With Sheet1.Range(Sheet1.[A2], Sheet1.[E65536].End(xlUp))
    Set FindCll1 = .Resize(, 1).Find(Thang, .Resize(1, 1), xlFormulas, 1, , 1)
    Set FindCll2 = .Resize(, 1).Find(Thang, .Resize(1, 1), xlFormulas, 1, , 2)
End With
If Not FindCll1 Is Nothing Then ArrNhap = Sheet1.Range(FindCll1, FindCll2).Resize(, 5)
With Sheet2.Range(Sheet2.[A2], Sheet2.[D65536].End(xlUp))
    Set FindCll1 = .Resize(, 1).Find(Thang, .Resize(1, 1), xlFormulas, 1, , 1)
    Set FindCll2 = .Resize(, 1).Find(Thang, .Resize(1, 1), xlFormulas, 1, , 2)
End With
If Not FindCll1 Is Nothing Then ArrXuat = Sheet2.Range(FindCll1, FindCll2).Resize(, 4)
If TypeName(ArrNhap) <> "Empty" Then
    For i = 1 To UBound(ArrNhap, 1)
        If DSHH.Exists(ArrNhap(i, 2)) Then
            KetQua(7, DSHH.Item(ArrNhap(i, 2))) = KetQua(7, DSHH.Item(ArrNhap(i, 2))) + ArrNhap(i, 4)
            KetQua(8, DSHH.Item(ArrNhap(i, 2))) = KetQua(8, DSHH.Item(ArrNhap(i, 2))) + ArrNhap(i, 5)
        Else
            SoDong = SoDong + 1
            ReDim Preserve KetQua(1 To 12, 1 To SoDong)
            STT = STT + 1
            KetQua(1, SoDong) = Thang
            KetQua(2, SoDong) = STT
            KetQua(3, SoDong) = ArrNhap(i, 2)
            KetQua(4, SoDong) = ArrNhap(i, 3)
            KetQua(7, SoDong) = ArrNhap(i, 4)
            KetQua(8, SoDong) = ArrNhap(i, 5)
            DSHH.Add KetQua(3, SoDong), SoDong
        End If
    Next
End If
If TypeName(ArrXuat) <> "Empty" Then
    For i = 1 To UBound(ArrXuat, 1)
        If DSHH.Exists(ArrXuat(i, 2)) Then
            KetQua(9, DSHH.Item(ArrXuat(i, 2))) = KetQua(9, DSHH.Item(ArrXuat(i, 2))) + ArrXuat(i, 4)
        Else
            SoDong = SoDong + 1
            ReDim Preserve KetQua(1 To 12, 1 To SoDong)
            STT = STT + 1
            KetQua(1, SoDong) = Thang
            KetQua(2, SoDong) = STT
            KetQua(3, SoDong) = ArrXuat(i, 2)
            KetQua(4, SoDong) = ArrXuat(i, 3)
            KetQua(9, SoDong) = ArrXuat(i, 4)
            DSHH.Add KetQua(3, SoDong), SoDong
        End If
    Next
End If
For Each ViTri In DSHH.Items
    If KetQua(5, ViTri) + KetQua(7, ViTri) <> 0 Then
        KetQua(10, ViTri) = KetQua(9, ViTri) * (KetQua(6, ViTri) + KetQua(8, ViTri)) / (KetQua(5, ViTri) + KetQua(7, ViTri))
    End If
    KetQua(11, ViTri) = KetQua(5, ViTri) + KetQua(7, ViTri) - KetQua(9, ViTri)
    KetQua(12, ViTri) = KetQua(6, ViTri) + KetQua(8, ViTri) - KetQua(10, ViTri)
Next
If TypeName(ArrNhap) <> "Empty" Then Erase ArrNhap
If TypeName(ArrXuat) <> "Empty" Then Erase ArrXuat
End Sub

Private Sub ChuyenSo(ByVal Thang As Long)
Dim MaHH, DicTam
Set DicTam = CreateObject("Scripting.Dictionary")
STT = 0
For Each MaHH In DSHH.Keys
    If KetQua(11, DSHH.Item(MaHH)) <> 0 Or KetQua(12, DSHH.Item(MaHH)) <> 0 Then
        SoDong = SoDong + 1
        ReDim Preserve KetQua(1 To 12, 1 To SoDong)
        STT = STT + 1
        DicTam.Add MaHH, SoDong
        KetQua(1, SoDong) = Thang
        KetQua(2, SoDong) = STT
        KetQua(3, SoDong) = MaHH
        KetQua(4, SoDong) = KetQua(4, DSHH.Item(MaHH))
        KetQua(5, SoDong) = KetQua(11, DSHH.Item(MaHH))
        KetQua(6, SoDong) = KetQua(12, DSHH.Item(MaHH))
    End If
Next
Set DSHH = DicTam
Set DicTam = Nothing
End Sub

Sub LapBaoCao()
Call SDDK
For i = 1 To 11
    Call NXTThang(i)
    Call ChuyenSo(i + 1)
Next
Call NXTThang(12)
Sheet4.UsedRange.Offset(3).ClearContents
Sheet4.[A4].Resize(SoDong, 12).Value = Application.WorksheetFunction.Transpose(KetQua)
Erase KetQua
Set DSHH = Nothing
End Sub

 

[ThuNghi]

Cám ơn Thắng nhiều. Quá công phu.
Code này giúp anh rất nhiều trong việc sổ sách.

 

[dongducnhiem]

Chào bạn Huuthang_bd và các thành viên
Tôi có áp dụng bài này vào bài thực tế của tôi, nhưng sau khi áp dụng thì code có báo một số lỗi sau:

1/ Ở đọan code dưới đây là tính trị giá xuất kho:

Em xin phép múa rìu qua mắt thợ vậy.

Sub TinhGiaXK(Rng As Range)

    Arr(i, 9) = (Arr(i, 5) + Arr(i, 7)) / (Arr(i, 4) + Arr(i, 6)) * Arr(i, 8)
    
   End Sub

Trong một tháng, nếu một mặt hàng nào không có tồn đầu kỳ VÀ phát sinh nhập thì sẽ bị báo lỗi, tương tự nếu có dòng trống xen giữa hoặc có các tiêu đề khác. (tương tự như công thức báo lỗi #DIV/0!)

2/ Khi chạy code, thì các cột có công thức (như cột A, G, H, I của các Sheet T01, T02, T03) bị dán thành hằng số (Paste Special values). Tôi muốn giữ lại công thức để lấy số liệu

3/ Thực tế khi sang một tháng mới, tôi tạo sheet T0... tương ứng, thì ta phải thay đổi thông số For i = 2 To 3

Sub Main()
Call TinhGiaXK(Rng1)
For i = 2 To 3
    End Sub

Không biết, trong lập trình có thể tự động thay đổi tương ứng với số Sheet T0... không.

Đối với VBA, tôi là tay tơ mơ, và File thực tế của tôi rất nặng, mong các bạn giúp đỡ hoàn chỉnh code nói trên. (Xem File đính kèm)
Chân thành cảm ơn!
------------------------

P/s: Nếu được các bạn giúp tôi viết code ở các cột G, H, I của các Sheet T01, T02, ... và các cột Q, R, S của Sheet TH. Nguyên tắc Công thức của các Sheet T01 ... chạy trước sau đó mới chạy công thức ớ sheet TH. (Nếu có gì chưa rõ, các bạn phản hồi giùm, để không mất thời gian & công sức của các bạn)