Giúp xây dựng code DIC cho bảng tổng hợp nhập xuất tồn. (1 người xem)

[hcm2015]

Mến chào các bạn!

Các bạn giúp mình thực hiện code DIC cho Sheet THNXT lấy dữ liệu lên bảng này theo điều kiện (Mình có sử dụng hàm Sumifs để mô tả trong file)

1. Dữ liệu được lấy lên sheet THNXT là từ sheet DM (Danh mục ; Sheet DM này dùng làm danh mục phát sinh mã cũng như cập nhật số dư đầu kỳ tại ngày 1/1/20xx), và sheet PS (Phát sinh)

2. Dữ liệu được lấy lên và tính số dư Tổng Hợp nhập xuất tồn theo ngày từ Ngày (ô F2) , tới ngày (ô F3) (như trên file đã thực hiện = hàm sumifs)

3. Mã hàng được lấy lên căn cứ theo sheet DM và Sheet PS, chỉ lấy những mã hàng nào có số dư đầu kỳ, hoặc phát sinh nhập xuất tại sheet PS theo điều kiện ngày đã chọn ở mục 2.

Theo trên file thì mã hàng HH008 (mã cũ) & HH019, HH020 (mã mới phát sinh) là không được lấy lên vì 3 mã này trong thời gian từ ngày tới ngày không có số dư, cũng như không có phát sinh nhập xuất. Mục đích của việc này là giới hạn lại danh sách khi load lên tại sheet THNXT (giống như 1 số phần mềm kế toán có chức năng này).

Nếu trường hợp qua các tháng khác (nếu có phát sinh 3 mã này trên sheet PS) thì khi xem dữ liệu từ ngày tới ngày tại sheet THNXT thì các mã này lại tự động lấy lên...trên sheet THNXT...

Hiện tại trên Sheet THNXT là mình làm bằng tay nên đã cố tình không cho xuất hiện 3 mã này trên đó.

Mong muốn của mình là lấy được dữ liệu lên sheet THNXT như mình đang làm, dữ liệu lấy tự động từ cột A tới cột L (cụ thể là từ A7 - chỉ tiêu đề là có sẵn)

Mong các bạn giúp mình thưc hiện ý đồ trên bằng code VBA DIC (Scripting.Dictionary)

Trân trọng cảm ơn mọi người đã đọc!

 

[VetMini]

Tức là bắt buôc phải đit. Đầu không được phải hôn?

 

[hcm2015]

Tức là bắt buôc phải đit. Đầu không được phải hôn?

Cảm ơn anh đã quan tâm. Vì thấy DIC rất hiệu quả. Nếu không phải DIC mà là công cụ khác tương tự thì cũng có thể giúp đỡ ạ! Mong được học hỏi & tích lũy thêm ạ!

 

[VetMini]

Dictionary là môt công cụ dùng để tra từ key sang value (item). Nếu gọi mã hàng là key thì value bạn muốn là cái gì?
Lưu ý rằng value càng nhiều thứ thì dic càng phức tạp.

 

[dhn46]

Tạm thời bạn check thử code sau

Sub XNT()
Dim ArrDM
Dim ArrPS
Dim ArrXNT
Dim Res
Dim KQ
Dim i As Long
Dim j As Long
Dim k As Long
Dim it As Long
Dim Dic As Object
Dim fDate As Date
Dim tDate As Date


Set Dic = CreateObject("Scripting.Dictionary")
fDate = Sheets("THNXT").[F2]
tDate = Sheets("THNXT").[F3]
ArrDM = Sheets("DM").Range("B5:G" & Sheets("DM").Range("B65536").End(3).Row)
ArrPS = Sheets("PS").Range("B3:J" & Sheets("PS").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(ArrDM, 1), 1 To 12)


With Dic
    'Add item to dic
    For i = 1 To UBound(ArrDM, 1)
        If Not .Exists(ArrDM(i, 1)) Then
            k = k + 1
            .Add ArrDM(i, 1), k
            'Add item to result array
            Res(k, 1) = k
            For j = 1 To 5
                Res(k, j + 1) = ArrDM(i, j)
            Next
        End If
    Next
    'Get PS data
    For i = 1 To UBound(ArrPS, 1)
        it = .Item(ArrPS(i, 3))
        'Ton PS
        If ArrPS(i, 2) < fDate Then
            Res(it, 5) = Res(it, 5) + ArrPS(i, 6)
            Res(it, 6) = Res(it, 6) + ArrPS(i, 8)
        ElseIf ArrPS(i, 2) >= fDate And ArrPS(i, 2) <= tDate Then
            'Nhap
            If ArrPS(i, 9) = "PN" Then
                Res(it, 7) = Res(it, 7) + ArrPS(i, 6)
                Res(it, 8) = Res(it, 8) + ArrPS(i, 8)
            'Xuat
            ElseIf ArrPS(i, 9) = "PX" Then
                Res(it, 9) = Res(it, 9) + ArrPS(i, 6)
                Res(it, 10) = Res(it, 10) + ArrPS(i, 8)
            End If
        End If
    Next
    'Caculate Ton cuoi
    For i = 1 To k
        Res(i, 11) = Res(i, 7) - Res(i, 9) + Res(i, 5)
        Res(i, 12) = Res(i, 8) - Res(i, 10) + Res(i, 6)
    Next
End With


ReDim KQ(1 To k + 1, 1 To 12)
'Remove blank
    For i = 1 To k
        tmp = 0
        For j = 5 To 10
            tmp = tmp + Res(i, j)
        Next
        If tmp > 0 Then
            t = t + 1
            KQ(t, 1) = t
            For j = 2 To 12
                KQ(t, j) = Res(i, j)
            Next
        End If
    Next
Sheets("THNXT").Range("A7").Resize(k, 12) = KQ


End Sub

 

[hcm2015]

Tạm thời bạn check thử code sau

Sub XNT()
..........
End Sub

Đã check. Code chạy quá chuẩn. Cảm ơn anh rất nhiều!

 

[dhn46]

Nếu Code bài #5 chuẩn rồi thì bạn dùng cái sau để có tổng cộng.

Viết Code dài 1 tí nhưng chia ra từng phần thế này hy vọng bạn sẽ áp dụng chỉnh sửa được vào thực tế

Sub XNT()
Dim ArrDM
Dim ArrPS
Dim ArrXNT
Dim Res
Dim KQ
Dim TongCong(1 To 1, 1 To 12)
Dim i As Long
Dim j As Long
Dim k As Long
Dim it As Long
Dim Dic As Object
Dim fDate As Date
Dim tDate As Date




Set Dic = CreateObject("Scripting.Dictionary")
fDate = Sheets("THNXT").[F2]
tDate = Sheets("THNXT").[F3]
ArrDM = Sheets("DM").Range("B5:G" & Sheets("DM").Range("B65536").End(3).Row)
ArrPS = Sheets("PS").Range("B3:J" & Sheets("PS").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(ArrDM, 1), 1 To 12)




With Dic
    'Add item to dic
    For i = 1 To UBound(ArrDM, 1)
        If Not .Exists(ArrDM(i, 1)) Then
            k = k + 1
            .Add ArrDM(i, 1), k
            'Add item to result array
            Res(k, 1) = k
            For j = 1 To 5
                Res(k, j + 1) = ArrDM(i, j)
            Next
        End If
    Next
    'Get PS data
    For i = 1 To UBound(ArrPS, 1)
        it = .Item(ArrPS(i, 3))
        'Ton PS
        If ArrPS(i, 2) < fDate Then
            Res(it, 5) = Res(it, 5) + ArrPS(i, 6)
            Res(it, 6) = Res(it, 6) + ArrPS(i, 8)
        ElseIf ArrPS(i, 2) >= fDate And ArrPS(i, 2) <= tDate Then
            'Nhap
            If ArrPS(i, 9) = "PN" Then
                Res(it, 7) = Res(it, 7) + ArrPS(i, 6)
                Res(it, 8) = Res(it, 8) + ArrPS(i, 8)
            'Xuat
            ElseIf ArrPS(i, 9) = "PX" Then
                Res(it, 9) = Res(it, 9) + ArrPS(i, 6)
                Res(it, 10) = Res(it, 10) + ArrPS(i, 8)
            End If
        End If
    Next
    'Caculate Ton cuoi
    For i = 1 To k
        Res(i, 11) = Res(i, 7) - Res(i, 9) + Res(i, 5)
        Res(i, 12) = Res(i, 8) - Res(i, 10) + Res(i, 6)
    Next
End With




ReDim KQ(1 To k + 1, 1 To 12)
'Remove blank
    For i = 1 To k
        tmp = 0
        For j = 5 To 10
            tmp = tmp + Res(i, j)
        Next
        If tmp > 0 Then
            t = t + 1
            KQ(t, 1) = t
            For j = 2 To 12
                KQ(t, j) = Res(i, j)
                If j > 4 Then
                    TongCong(1, j) = TongCong(1, j) + Res(i, j)
                End If
            Next
        End If
    Next
    'Add text Tong Cong
    TongCong(1, 3) = "T" & ChrW(7893) & "ng" & " C" & ChrW(7897) & "ng"
'Clear data
Sheets("THNXT").Range("A7:L65536").ClearContents
'Data
Sheets("THNXT").Range("A7").Resize(k, 12) = KQ
'Tong Cong
Sheets("THNXT").Range("A" & t + 7).Resize(1, 12) = TongCong
End Sub