Nhờ giúp tính tồn kho bằng Dictionary (2 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)
H

hanhpptc

Thành viên tiêu biểu
Tham gia
16/5/08
Bài viết
459
Được thích
320
Mình có đọc và học trên diễn đàn về Dic và thấy hay quá. Song khi áp dụng về mảng để tính xuất, nhập, tồn thì số liệu có sai. Mình biết là sai ở các phần thêm, sửa Item của Dic nhưng không tài nào chỉnh được. Mong các cao thủ trợ giúp. File VD đính kèm.
 

File đính kèm

hanhpptc đã viết:
Mình có đọc và học trên diễn đàn về Dic và thấy hay quá. Song khi áp dụng về mảng để tính xuất, nhập, tồn thì số liệu có sai. Mình biết là sai ở các phần thêm, sửa Item của Dic nhưng không tài nào chỉnh được. Mong các cao thủ trợ giúp. File VD đính kèm.
Nhấp chuột vào đây để mở rộng...
Thử thay Sub của bạn bằng cái này thử xem:
PHP: 
Public Sub GPE()
Dim Rng1(), Rng2(), Rng3(), Arr(), I As Long, J As Long, K As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
    Rng1 = Sheets("DM").Range(Sheets("DM").[A2], Sheets("DM").[A65000].End(xlUp)).Resize(, 4).Value
    Rng2 = Sheets("Nhap").Range(Sheets("Nhap").[B2], Sheets("Nhap").[B65000].End(xlUp)).Resize(, 3).Value
    Rng3 = Sheets("Xuat").Range(Sheets("Xuat").[B2], Sheets("Xuat").[B65000].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng1, 1), 1 To 8)
    For I = 1 To UBound(Rng1, 1)
        If Not Dic.exists(Rng1(I, 1)) Then
            K = K + 1
            Dic.Add Rng1(I, 1), K
                Arr(K, 1) = K: Arr(K, 8) = Rng1(I, 4)
                For J = 1 To 4
                    Arr(K, J + 1) = Rng1(I, J)
                Next
        End If
    Next I
        For I = 1 To UBound(Rng2, 1)
            If Dic.exists(Rng2(I, 2)) Then
                If Rng2(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng2(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                    Arr(Dic.Item(Rng2(I, 2)), 6) = Arr(Dic.Item(Rng2(I, 2)), 6) + Rng2(I, 3)
                    Arr(Dic.Item(Rng2(I, 2)), 8) = Arr(Dic.Item(Rng2(I, 2)), 8) + Rng2(I, 3)
                End If
            End If
        Next I
            For I = 1 To UBound(Rng3, 1)
                If Dic.exists(Rng3(I, 2)) Then
                    If Rng3(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng3(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                        Arr(Dic.Item(Rng3(I, 2)), 7) = Arr(Dic.Item(Rng3(I, 2)), 7) + Rng3(I, 3)
                        Arr(Dic.Item(Rng3(I, 2)), 8) = Arr(Dic.Item(Rng3(I, 2)), 8) - Rng3(I, 3)
                    End If
                End If
            Next I
        If K Then Sheets("Bao Cao").[A5].Resize(K, 8).Value = Arr
Set Dic = Nothing
End Sub
 
Ba Tê đã viết:
Thử thay Sub của bạn bằng cái này thử xem:
Nhấp chuột vào đây để mở rộng...
Cám ơn Ba Tê đã hướng dẫn, nhưng hình như phần hàng tồn đầu kỳ còn sai (Chương trình lấy đầu năm, chưa trừ phần nhập - xuất trước đó). Chọn kỳ báo cáo 15/01/2012 đến 31/01/2012 sẽ thấy.
 
Cám ơn bác Ba Tê nhiều. Mình đã chỉnh sửa Code theo hướng dấn của bác và đã giải quyết được vấn đề.
Sub GPE_Hanh()
Dim Rng1(), Rng2(), Rng3(), Arr(), I As Long, J As Long, K As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Rng1 = Sheets("DM").Range(Sheets("DM").[A2], Sheets("DM").[A65000].End(xlUp)).Resize(, 4).Value
Rng2 = Sheets("Nhap").Range(Sheets("Nhap").[B2], Sheets("Nhap").[B65000].End(xlUp)).Resize(, 3).Value
Rng3 = Sheets("Xuat").Range(Sheets("Xuat").[B2], Sheets("Xuat").[B65000].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng1, 1), 1 To 8)
For I = 1 To UBound(Rng1, 1)
If Not Dic.exists(Rng1(I, 1)) Then
K = K + 1
Dic.Add Rng1(I, 1), K
Arr(K, 1) = K: Arr(K, 8) = Rng1(I, 4)
For J = 1 To 4
Arr(K, J + 1) = Rng1(I, J)
Next
End If
Next I
For I = 1 To UBound(Rng2, 1)
If Dic.exists(Rng2(I, 2)) Then
If Rng2(I, 1) < Sheets("Bao Cao").[D2].Value Then
Arr(Dic.Item(Rng2(I, 2)), 5) = Arr(Dic.Item(Rng2(I, 2)), 5) + Rng2(I, 3)
Arr(Dic.Item(Rng2(I, 2)), 8) = Arr(Dic.Item(Rng2(I, 2)), 8) + Rng2(I, 3)
End If
If Rng2(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng2(I, 1) <= Sheets("Bao Cao").[D3].Value Then
Arr(Dic.Item(Rng2(I, 2)), 6) = Arr(Dic.Item(Rng2(I, 2)), 6) + Rng2(I, 3)
Arr(Dic.Item(Rng2(I, 2)), 8) = Arr(Dic.Item(Rng2(I, 2)), 8) + Rng2(I, 3)
End If
End If
Next I
For I = 1 To UBound(Rng3, 1)
If Dic.exists(Rng3(I, 2)) Then
If Rng3(I, 1) < Sheets("Bao Cao").[D2].Value Then
Arr(Dic.Item(Rng3(I, 2)), 5) = Arr(Dic.Item(Rng3(I, 2)), 5) - Rng3(I, 3)
Arr(Dic.Item(Rng3(I, 2)), 8) = Arr(Dic.Item(Rng3(I, 2)), 8) - Rng3(I, 3)
End If
If Rng3(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng3(I, 1) <= Sheets("Bao Cao").[D3].Value Then
Arr(Dic.Item(Rng3(I, 2)), 7) = Arr(Dic.Item(Rng3(I, 2)), 7) + Rng3(I, 3)
Arr(Dic.Item(Rng3(I, 2)), 8) = Arr(Dic.Item(Rng3(I, 2)), 8) - Rng3(I, 3)
End If
End If
Next I
If K Then Sheets("Bao Cao").[A5].Resize(K, 8).Value = Arr
Set Dic = Nothing
End Sub
 
hanhpptc đã viết:
Cám ơn Ba Tê đã hướng dẫn, nhưng hình như phần hàng tồn đầu kỳ còn sai (Chương trình lấy đầu năm, chưa trừ phần nhập - xuất trước đó). Chọn kỳ báo cáo 15/01/2012 đến 31/01/2012 sẽ thấy.
Nhấp chuột vào đây để mở rộng...
Thử lại với code này xem:
PHP: 
Public Sub GPE()
Dim Rng1(), Rng2(), Rng3(), Arr(), I As Long, J As Long, K As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
    Rng1 = Sheets("DM").Range(Sheets("DM").[A2], Sheets("DM").[A65000].End(xlUp)).Resize(, 4).Value
    Rng2 = Sheets("Nhap").Range(Sheets("Nhap").[B2], Sheets("Nhap").[B65000].End(xlUp)).Resize(, 3).Value
    Rng3 = Sheets("Xuat").Range(Sheets("Xuat").[B2], Sheets("Xuat").[B65000].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng1, 1), 1 To 8)
    For I = 1 To UBound(Rng1, 1)
        If Not Dic.exists(Rng1(I, 1)) Then
            K = K + 1
            Dic.Add Rng1(I, 1), K
                Arr(K, 1) = K
                For J = 1 To 4
                    Arr(K, J + 1) = Rng1(I, J)
                Next
        End If
    Next I
        For I = 1 To UBound(Rng2, 1)
            If Dic.exists(Rng2(I, 2)) Then
                If Rng2(I, 1) < Sheets("Bao Cao").[D2].Value Then
                    Arr(Dic.Item(Rng2(I, 2)), 5) = Arr(Dic.Item(Rng2(I, 2)), 5) + Rng2(I, 3)
                ElseIf Rng2(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng2(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                    Arr(Dic.Item(Rng2(I, 2)), 6) = Arr(Dic.Item(Rng2(I, 2)), 6) + Rng2(I, 3)
                End If
            End If
        Next I
            For I = 1 To UBound(Rng3, 1)
                If Dic.exists(Rng3(I, 2)) Then
                    If Rng3(I, 1) < Sheets("Bao Cao").[D2].Value Then
                        Arr(Dic.Item(Rng3(I, 2)), 5) = Arr(Dic.Item(Rng3(I, 2)), 5) - Rng3(I, 3)
                    ElseIf Rng3(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng3(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                        Arr(Dic.Item(Rng3(I, 2)), 7) = Arr(Dic.Item(Rng3(I, 2)), 7) + Rng3(I, 3)
                    End If
                       Arr(Dic.Item(Rng3(I, 2)), 8) = Arr(Dic.Item(Rng3(I, 2)), 5) + Arr(Dic.Item(Rng3(I, 2)), 6) - Arr(Dic.Item(Rng3(I, 2)), 7)
                End If
            Next I
        If K Then Sheets("Bao Cao").[A5].Resize(K, 8).Value = Arr
Set Dic = Nothing
End Sub
 
Ba Tê đã viết:
Thử lại với code này xem:
PHP: 
Public Sub GPE()
Dim Rng1(), Rng2(), Rng3(), Arr(), I As Long, J As Long, K As Long, Dic As Object
' ...'        For I = 1 To UBound(Rng2, 1)
             If Dic.exists(Rng2(I, 2)) Then
...
            For I = 1 To UBound(Rng3, 1)
                If Dic.exists(Rng3(I, 2)) Then
Nhấp chuột vào đây để mở rộng...

Theo em nên cân nhắc dòng If Dic.exists(Rng2(I, 2)), vì theo như bài là tất cả mã hàng đều phải đăng ký vào DM.
Còn nhiều trường hợp nếu nhập hay xuất mà chưa có trong DM thì sẽ xử lý thêm nhiều hướng.
Công nhận Bác BaTê vận dụng Dic vào kế toán quá siêu.
 
Ba Tê đã viết:
Thử lại với code này xem:
PHP: 
Public Sub GPE()
..........
End Sub
Nhấp chuột vào đây để mở rộng...

Còn vấn đề này nữa, theo em nghĩ sẽ tăng tốc hơn:

Ta thêm 1 biến tmp rồi dùng biến tmp này thay thế Dic.Item(Rng3(i, 2))

Mã: 
            For i = 1 To UBound(Rng3, 1)
                If Dic.exists(Rng3(i, 2)) Then
                    [COLOR=#0000cd][B]tmp = Dic.Item(Rng3(i, 2))[/B][/COLOR]
                    If Rng3(i, 1) < Sheets("Bao Cao").[D2].Value Then
                        Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 5) = Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 5) - Rng3(i, 3)
                    ElseIf Rng3(i, 1) >= Sheets("Bao Cao").[D2].Value And _
                           Rng3(i, 1) <= Sheets("Bao Cao").[D3].Value Then
                        Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 7) = Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 7) + Rng3(i, 3)
                    End If
                    Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 8) = Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 5) + Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 6) - Arr([COLOR=#0000cd][B]tmp [/B][/COLOR], 7)
                End If
            Next i

Nghĩ thấy nó sẽ nhanh hơn vì không phải tính đến ít nhất 6 lần và code sẽ gọn gàng hơn.
 
Lần chỉnh sửa cuối:
Chào bác Ba Tê, em cũng có file tính tổng tương tự nhưng số cột cần tính nhiều hơn nên e vận dụng công thức của bàc vào chưa được. Cần bác giúp ạh
Bài đã được tự động gộp:

Ba Tê đã viết:
Thử lại với code này xem:
PHP: 
Public Sub GPE()
Dim Rng1(), Rng2(), Rng3(), Arr(), I As Long, J As Long, K As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
    Rng1 = Sheets("DM").Range(Sheets("DM").[A2], Sheets("DM").[A65000].End(xlUp)).Resize(, 4).Value
    Rng2 = Sheets("Nhap").Range(Sheets("Nhap").[B2], Sheets("Nhap").[B65000].End(xlUp)).Resize(, 3).Value
    Rng3 = Sheets("Xuat").Range(Sheets("Xuat").[B2], Sheets("Xuat").[B65000].End(xlUp)).Resize(, 3).Value
ReDim Arr(1 To UBound(Rng1, 1), 1 To 8)
    For I = 1 To UBound(Rng1, 1)
        If Not Dic.exists(Rng1(I, 1)) Then
            K = K + 1
            Dic.Add Rng1(I, 1), K
                Arr(K, 1) = K
                For J = 1 To 4
                    Arr(K, J + 1) = Rng1(I, J)
                Next
        End If
    Next I
        For I = 1 To UBound(Rng2, 1)
            If Dic.exists(Rng2(I, 2)) Then
                If Rng2(I, 1) < Sheets("Bao Cao").[D2].Value Then
                    Arr(Dic.Item(Rng2(I, 2)), 5) = Arr(Dic.Item(Rng2(I, 2)), 5) + Rng2(I, 3)
                ElseIf Rng2(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng2(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                    Arr(Dic.Item(Rng2(I, 2)), 6) = Arr(Dic.Item(Rng2(I, 2)), 6) + Rng2(I, 3)
                End If
            End If
        Next I
            For I = 1 To UBound(Rng3, 1)
                If Dic.exists(Rng3(I, 2)) Then
                    If Rng3(I, 1) < Sheets("Bao Cao").[D2].Value Then
                        Arr(Dic.Item(Rng3(I, 2)), 5) = Arr(Dic.Item(Rng3(I, 2)), 5) - Rng3(I, 3)
                    ElseIf Rng3(I, 1) >= Sheets("Bao Cao").[D2].Value And Rng3(I, 1) <= Sheets("Bao Cao").[D3].Value Then
                        Arr(Dic.Item(Rng3(I, 2)), 7) = Arr(Dic.Item(Rng3(I, 2)), 7) + Rng3(I, 3)
                    End If
                       Arr(Dic.Item(Rng3(I, 2)), 8) = Arr(Dic.Item(Rng3(I, 2)), 5) + Arr(Dic.Item(Rng3(I, 2)), 6) - Arr(Dic.Item(Rng3(I, 2)), 7)
                End If
            Next I
        If K Then Sheets("Bao Cao").[A5].Resize(K, 8).Value = Arr
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Chào bác Ba Tê, em cũng có file tính tổng tương tự nhưng số cột cần tính nhiều hơn nên e vận dụng công thức của bàc vào chưa được. Cần bác giúp ạh
 

File đính kèm

Lần chỉnh sửa cuối:
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

vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (2 người xem)
Trả lời
13
Đọc
98
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
175
Gà Công Nghệ
Gà Công Nghệ
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
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
520
Phạm Trường 80
P
L
Lỗi font khi convert từ pdf
Trả lời
1
Đọc
53
Hoàng Tuấn 868
H
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
76
SA_DQ
SA_DQ
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
2
Đọc
75
DeTong
D
H
Đổi số thành chữ trong office 365
Trả lời
19
Đọc
1K
HoangTan891026
H
Gà Công Nghệ
Lấy dữ liệu file excel từ sheet này sang sheet khác
Trả lời
4
Đọc
129
Gà Công Nghệ
Gà Công Nghệ
N
Mong mọi người giúp đỡ
Trả lời
1
Đọc
59
minhminh27
minhminh27
minhduc1o2
Excel lỗi font Time New Roman+
Trả lời
7
Đọc
116
minhduc1o2
minhduc1o2
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
0
Đọc
75
fujishima
F
H
Lọc dữ liệu trong XL
    • Cười
Trả lời
0
Đọc
46
huong.dinh
H
giaiphap
Add-Ins hổ trợ Word trộn danh sách và lưu ra nhiều tệp tin khác nhau.
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
39
Đọc
9K
fujishima
F
K
xin file excel bảng đấu bóng đá
    • Yêu thích
2 3
Trả lời
40
Đọc
25K
subin1905
S
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
24
Đọc
7K
chihuumvc
C
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
1
Đọc
65
bebo021999
B
G
Hướng dẫn Lập danh sách File
    • Không thích
Trả lời
16
Đọc
267
thanhhuy_hvnh
thanhhuy_hvnh
baolong240793
Nhờ Anh/Chị hỗ trợ em hàm Randbetween() với ạ. (1 người xem)
Trả lời
4
Đọc
362
bebo021999
B
Y
  • Question Question
Khóa VBA với mật khẩu mở
    • Thích
2 3 4
Trả lời
60
Đọc
5K
PhanTuHuong
PhanTuHuong
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