Tổng hợp kho hang băng VBA (1 người xem)

[bongmaihung]

Chào anh, chị,
Em có file tổng hợp xuất nhập tồn đính kèm, nếu chỉ lọc trùng và tính tổng trong khoảng thời gian em đã làm được. Nhưng để chuyển được số dư đầu ký , sau đó lọc trùng và tính tổng thì em chưa làm được. Chi tiết em ghi trong sheet 2, nhờ mọi người giúp đỡ, Em cảm ơn

 

[comet_1701]

Chào anh, chị,
Em có file tổng hợp xuất nhập tồn đính kèm, nếu chỉ lọc trùng và tính tổng trong khoảng thời gian em đã làm được. Nhưng để chuyển được số dư đầu ký , sau đó lọc trùng và tính tổng thì em chưa làm được. Chi tiết em ghi trong sheet 2, nhờ mọi người giúp đỡ, Em cảm ơn

Sub Dic()
Dim Sarr, Darr, i As Long, k As Long, j As Long, TMP, Tungay, Denngay, Rws As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("XUAT")
    Sarr = .Range(.[B3], .[B65000].End(3)).Resize(, 10).Value2
End With
ReDim Darr(1 To UBound(Sarr, 1), 1 To 7)
With Sheets("TH")
Tungay = .[F2]
Denngay = .[F3]
For i = 1 To UBound(Sarr)
TMP = Sarr(i, 6)
 If Not Dic.Exists(TMP) Then
      
        k = k + 1
        Dic.Add TMP, k
        Darr(k, 1) = k
        Darr(k, 2) = TMP
        Darr(k, 3) = Sarr(i, 7)
        If Sarr(i, 1) < Tungay Then
            Darr(k, 5) = Sarr(i, 9) - Sarr(i, 10)
        ElseIf Sarr(i, 1) <= Denngay Then
            Darr(k, 6) = Sarr(i, 9)
            Darr(k, 7) = Sarr(i, 10)
        End If
    Else
        Rws = Dic.Item(TMP)
        If Sarr(i, 1) < Tungay Then
            Darr(Rws, 5) = Darr(Rws, 5) + Sarr(i, 9) - Sarr(i, 10)
        ElseIf Sarr(i, 1) <= Denngay Then
            Darr(Rws, 6) = Darr(Rws, 6) + Sarr(i, 9)
               Darr(Rws, 7) = Darr(Rws, 7) + Sarr(i, 10)
        End If
End If


Next
If k Then
.[A6:H65000].ClearContents
.[A6].Resize(k, 7).Value = Darr
End If
End With
Set Dic = Nothing
End Sub

Bạn thử phát triển tiếp xem. Chưa kịp test, có gì bạn phản hồi lại nhé

 

[SA_DQ]

Sub Dic()
Dim Sarr, Darr, Dic As Object:                     Dim TMP As String 
Dim i As Long, k As Long, j As Long,  Tungay, Denngay, Rws As Long

Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("XUAT")
    Sarr = .Range(.[B3], .[B65000].End(3)).Resize(, 10).Value2
End With
ReDim Darr(1 To UBound(Sarr, 1), 1 To 7)
With Sheets("TH")
Tungay = .[F2]:                               Denngay = .[F3]
For i = 1 To UBound(Sarr)

'. . . . . .  '

Next
If k Then
.[A6:H65000].ClearContents
.[A6].Resize(k, 7).Value = Darr
End If
End With
Set Dic = Nothing
End Sub

Bạn thử phát triển tiếp xem. Chưa kịp test, có gì bạn phản hồi lại nhé

Vì tác giả bài đăng để dòng trống sau mỗi ngày nhập xuất;
Cho nên chương trình sẽ tổng hợp thừa 1 dòng (thể hiện dòng trống này)

Để khác fục tác giả bài đăng nên thêm câu lệnh ngay sau vòng lặp For . . . . Next nêu trên:

[B]     If sArr(I, 6) <> "" Then
[COLOR=#0000cd]'. . . . . . . . . '
[/COLOR]
       End If 
[/B]