Anh Chị Giúp Em Hoàn Thiện Code VBA

[langkhachquaduong]

Mình chào cả nhà, hiện mình đang làm 1 file báo cáo, mình đang gặp khó khăn ở chỗ là mình muốn lấy tổng từng công ty và tổng cộng tất cả công ty. Mình cũng đã viết code nhưng đang gặp khó khăn trên. Rất mong các bạn hỗ trợ. Mình cảm ơn.

 

[be_09]

Mình chào cả nhà, hiện mình đang làm 1 file báo cáo, mình đang gặp khó khăn ở chỗ là mình muốn lấy tổng từng công ty và tổng cộng tất cả công ty. Mình cũng đã viết code nhưng đang gặp khó khăn trên. Rất mong các bạn hỗ trợ. Mình cảm ơn.

Góp ý cho bạn:
1/ Bạn cần sửa ngày tiêu đề là "Lọc dữ liệu khách hàng từ ngày đến ngày và tổng hợp".
2/ File của bạn hình như xuất ra từ phần mềm thì phải. Sheet KPI định dạng Date trong khi đó cột A sheet BCDonHang............lại là dạng Text nên không thể lọc được, Trong code sẽ Copy sang cột G để lọc. Bạn chỉ cần Copy dữ liệu vào rồi nhấn nút.
3/ Về tổng hợp, sau khi lọc xong thì sử dụng PivotTable (xem trong File).

 

[langkhachquaduong]

Dạ. File này mình down từ phần mềm xuống. Cái này thì dùng pivottable là có thể tổng hợp là ra.
Yêu cầu của mình là hỗ trợ giúp mình đoạn code tổng hợp thành tiền từng công ty.

 

[Nhattanktnn]

Dạ. File này mình down từ phần mềm xuống. Cái này thì dùng pivottable là có thể tổng hợp là ra.
Yêu cầu của mình là hỗ trợ giúp mình đoạn code tổng hợp thành tiền từng công ty.

Không biết phải vậy không

Option Explicit
Sub TongTien()
Application.ScreenUpdating = False
Dim sArr(), dArr(), Txt$, I&, J&, K&, Lr&, Dic As Object
Dim Fdate As Date, Tdate As Date
Set Dic = CreateObject("Scripting.Dictionary")
Sheets("KPI").Range("I19").Resize(10000, 3).ClearContents
With Sheets("BCDonHangBanTrongKyNPP")
    Lr = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:F" & Lr).Value
End With
Fdate = Sheets("KPI").Range("B6").Value2
Tdate = Sheets("KPI").Range("B7").Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    Txt = sArr(I, 2) & sArr(I, 6)
    If sArr(I, 1) >= Fdate And sArr(I, 1) <= Tdate Then
        If Not Dic.exists(Txt) Then
            K = K + 1
            Dic.Add (Txt), K
            dArr(K, 1) = sArr(I, 6): dArr(K, 2) = sArr(I, 2): dArr(K, 3) = sArr(I, 5)
            Else
            dArr(Dic.Item(Txt), 3) = dArr(Dic.Item(Txt), 3) + sArr(I, 5)
        End If
    End If
Next
Sheets("KPI").Range("I19").Resize(K, 3) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

 

[langkhachquaduong]

Không biết phải vậy không

Option Explicit
Sub TongTien()
Application.ScreenUpdating = False
Dim sArr(), dArr(), Txt$, I&, J&, K&, Lr&, Dic As Object
Dim Fdate As Date, Tdate As Date
Set Dic = CreateObject("Scripting.Dictionary")
Sheets("KPI").Range("I19").Resize(10000, 3).ClearContents
With Sheets("BCDonHangBanTrongKyNPP")
    Lr = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:F" & Lr).Value
End With
Fdate = Sheets("KPI").Range("B6").Value2
Tdate = Sheets("KPI").Range("B7").Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    Txt = sArr(I, 2) & sArr(I, 6)
    If sArr(I, 1) >= Fdate And sArr(I, 1) <= Tdate Then
        If Not Dic.exists(Txt) Then
            K = K + 1
            Dic.Add (Txt), K
            dArr(K, 1) = sArr(I, 6): dArr(K, 2) = sArr(I, 2): dArr(K, 3) = sArr(I, 5)
            Else
            dArr(Dic.Item(Txt), 3) = dArr(Dic.Item(Txt), 3) + sArr(I, 5)
        End If
    End If
Next
Sheets("KPI").Range("I19").Resize(K, 3) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

Thank cả nhà mình đã tìm ra giai pháp