Code thay thế sumproduct bằng VBA (1 người xem)

thinhnx22 · 7/10/17

Gửi các anh chị thành viên,
Mình đang muốn tổng hợp số lượng của từng mã hàng trong một khoảng thời gian. Dùng hàm sumproduct thì khá nặng vì số liệu cũng lớn. Mã hàng ở sheet Tổng hợp là không được phép thay đổi (mã cố định).
yêu cầu cần giúp đỡ mình đã ghi trong file đính kèm. Rất mong được sự trợ giúp của tất cả mọi người.
Chân thành cảm ơn.

Hoang2013 · 7/10/17

Tốc độ sẽ được cải thiện với macro này:

PHP:

Sub TongHopTheoDoanThoiGian()
 Dim Sh As Worksheet, Arr(), Cls As Range
 Dim Rws As Long, fDat As Date, lDat As Date, J As Long, SoLg As Double
 Set Sh = ThisWorkbook.Worksheets("Nguon")
 Rws = Sh.[A4].CurrentRegion.Rows.Count
 Arr() = Sh.[A4].Resize(Rws, 3).Value
 Sheets("TongHop").Select
 fDat = [B4].Value:                 lDat = [d4].Value
 For Each Cls In Range([A7], [A7].End(xlDown))
    For J = 1 To UBound(Arr())
        If (Arr(J, 1) >= fDat And Arr(J, 1) <= lDat) And Arr(J, 2) = Cls.Value Then
            SoLg = SoLg + Arr(J, 3)
        End If
    Next J
    Cls.Offset(, 1).Value = SoLg:           SoLg = 0
 Next Cls
End Sub

thinhnx22 · 7/10/17

Hoang2013 đã viết:

Tốc độ sẽ được cải thiện với macro này:

PHP:

Sub TongHopTheoDoanThoiGian()
 Dim Sh As Worksheet, Arr(), Cls As Range
 Dim Rws As Long, fDat As Date, lDat As Date, J As Long, SoLg As Double
 Set Sh = ThisWorkbook.Worksheets("Nguon")
 Rws = Sh.[A4].CurrentRegion.Rows.Count
 Arr() = Sh.[A4].Resize(Rws, 3).Value
 Sheets("TongHop").Select
 fDat = [B4].Value:                 lDat = [d4].Value
 For Each Cls In Range([A7], [A7].End(xlDown))
    For J = 1 To UBound(Arr())
        If (Arr(J, 1) >= fDat And Arr(J, 1) <= lDat) And Arr(J, 2) = Cls.Value Then
            SoLg = SoLg + Arr(J, 3)
        End If
    Next J
    Cls.Offset(, 1).Value = SoLg:           SoLg = 0
 Next Cls
End Sub

Mình test thử , thấy ok roài. Cảm ơn bạn nhiều nhé

Horse · 7/10/17

thinhnx22 đã viết:
Gửi các anh chị thành viên,
Mình đang muốn tổng hợp số lượng của từng mã hàng trong một khoảng thời gian. Dùng hàm sumproduct thì khá nặng vì số liệu cũng lớn. Mã hàng ở sheet Tổng hợp là không được phép thay đổi (mã cố định).
yêu cầu cần giúp đỡ mình đã ghi trong file đính kèm. Rất mong được sự trợ giúp của tất cả mọi người.
Chân thành cảm ơn.

Bạn chạy thử cái 2 Dic này xem sao

Mã:

Option Explicit
Public Sub GPE()
    Dim sArr(), dArr(), tArr(), I As Long, K As Long
    Dim Dic As Object, Dic1 As Object, R As Long
    Dim Ngay As Long, fDAte As Long, eDate  As Long
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic1 = CreateObject("Scripting.Dictionary")
With Sheets("TONGHOP")
    fDAte = .Range("B4").Value2:    eDate = .Range("D4").Value2
    tArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("NGUON")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 3).Value
    ReDim dArr(1 To UBound(tArr), 1 To 1)
    For I = 1 To UBound(sArr)
        R = Dic.Item(sArr(I, 2))
        If R Then
            Ngay = sArr(I, 1)
            If Ngay <= eDate Then
                If Ngay >= fDAte Then
                    If K < R Then K = R
                    If Not Dic1.Exists(sArr(I, 2)) Then
                        Dic1.Add sArr(I, 2), R
                        dArr(R, 1) = sArr(I, 3)
                    Else
                        dArr(Dic1.Item(sArr(I, 2)), 1) = dArr(Dic1.Item(sArr(I, 2)), 1) + sArr(I, 3)
                    End If
                End If
            End If
        End If
    Next I
End With
With Sheets("TONGHOP")
    .Range("B7").Resize(K).ClearContents
    If K Then
        .Range("B7").Resize(K, 1) = dArr
    End If
End With
Set Dic = Nothing
Set Dic1 = Nothing
End Sub

thinhnx22 · 7/10/17

Horse đã viết:

Bạn chạy thử cái 2 Dic này xem sao

Mã:

Option Explicit
Public Sub GPE()
    Dim sArr(), dArr(), tArr(), I As Long, K As Long
    Dim Dic As Object, Dic1 As Object, R As Long
    Dim Ngay As Long, fDAte As Long, eDate  As Long
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic1 = CreateObject("Scripting.Dictionary")
With Sheets("TONGHOP")
    fDAte = .Range("B4").Value2:    eDate = .Range("D4").Value2
    tArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("NGUON")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 3).Value
    ReDim dArr(1 To UBound(tArr), 1 To 1)
    For I = 1 To UBound(sArr)
        R = Dic.Item(sArr(I, 2))
        If R Then
            Ngay = sArr(I, 1)
            If Ngay <= eDate Then
                If Ngay >= fDAte Then
                    If K < R Then K = R
                    If Not Dic1.Exists(sArr(I, 2)) Then
                        Dic1.Add sArr(I, 2), R
                        dArr(R, 1) = sArr(I, 3)
                    Else
                        dArr(Dic1.Item(sArr(I, 2)), 1) = dArr(Dic1.Item(sArr(I, 2)), 1) + sArr(I, 3)
                    End If
                End If
            End If
        End If
    Next I
End With
With Sheets("TONGHOP")
    .Range("B7").Resize(K).ClearContents
    If K Then
        .Range("B7").Resize(K, 1) = dArr
    End If
End With
Set Dic = Nothing
Set Dic1 = Nothing
End Sub

Code rất ổn. Cảm ơn bạn nhiều nhá.

ndu96081631 · 7/10/17

thinhnx22 đã viết:
Gửi các anh chị thành viên,
Mình đang muốn tổng hợp số lượng của từng mã hàng trong một khoảng thời gian. Dùng hàm sumproduct thì khá nặng vì số liệu cũng lớn. Mã hàng ở sheet Tổng hợp là không được phép thay đổi (mã cố định).
yêu cầu cần giúp đỡ mình đã ghi trong file đính kèm. Rất mong được sự trợ giúp của tất cả mọi người.
Chân thành cảm ơn.

Thế sao bạn không thay SUMPRODUCT thành SUMIFS? Tôi nghĩ chỉ cần thế cũng có thể khiến file nhẹ đi đáng kể đấy

HieuCD · 7/10/17

Horse đã viết:

Bạn chạy thử cái 2 Dic này xem sao

Mã:

Option Explicit
Public Sub GPE()
    Dim sArr(), dArr(), tArr(), I As Long, K As Long
    Dim Dic As Object, Dic1 As Object, R As Long
    Dim Ngay As Long, fDAte As Long, eDate  As Long
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic1 = CreateObject("Scripting.Dictionary")
With Sheets("TONGHOP")
    fDAte = .Range("B4").Value2:    eDate = .Range("D4").Value2
    tArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("NGUON")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 3).Value
    ReDim dArr(1 To UBound(tArr), 1 To 1)
    For I = 1 To UBound(sArr)
        R = Dic.Item(sArr(I, 2))
        If R Then
            Ngay = sArr(I, 1)
            If Ngay <= eDate Then
                If Ngay >= fDAte Then
                    If K < R Then K = R
                    If Not Dic1.Exists(sArr(I, 2)) Then
                        Dic1.Add sArr(I, 2), R
                        dArr(R, 1) = sArr(I, 3)
                    Else
                        dArr(Dic1.Item(sArr(I, 2)), 1) = dArr(Dic1.Item(sArr(I, 2)), 1) + sArr(I, 3)
                    End If
                End If
            End If
        End If
    Next I
End With
With Sheets("TONGHOP")
    .Range("B7").Resize(K).ClearContents
    If K Then
        .Range("B7").Resize(K, 1) = dArr
    End If
End With
Set Dic = Nothing
Set Dic1 = Nothing
End Sub

Dic1 và K có cần không?

Horse · 7/10/17

HieuCD đã viết:
Dic1 và K có cần không?

Em lại rồi. Nó thừa anh ạ
Em chỉnh lại như thế này:

PHP:

Public Sub GPE()
    Dim sArr(), dArr(), tArr(), I As Long
    Dim Dic As Object, R As Long
    Dim Ngay As Long, fDAte As Long, eDate  As Long
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TONGHOP")
    fDAte = .Range("B4").Value:    eDate = .Range("D4").Value
    tArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("NGUON")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 3).Value
    ReDim dArr(1 To UBound(tArr), 1 To 1)
    For I = 1 To UBound(sArr)
        R = Dic.Item(sArr(I, 2))
        If R Then
            Ngay = sArr(I, 1)
            If Ngay <= eDate Then
                If Ngay >= fDAte Then
                    dArr(R, 1) = dArr(R, 1) + sArr(I, 3)
                End If
            End If
        End If
    Next I
End With
With Sheets("TONGHOP")
    .Range("B7").Resize(UBound(tArr)).ClearContents
    .Range("B7").Resize(UBound(tArr), 1) = dArr
End With
Set Dic = Nothing
End Sub

HieuCD · 7/10/17

thinhnx22 đã viết:
Gửi các anh chị thành viên,
Mình đang muốn tổng hợp số lượng của từng mã hàng trong một khoảng thời gian. Dùng hàm sumproduct thì khá nặng vì số liệu cũng lớn. Mã hàng ở sheet Tổng hợp là không được phép thay đổi (mã cố định).
yêu cầu cần giúp đỡ mình đã ghi trong file đính kèm. Rất mong được sự trợ giúp của tất cả mọi người.
Chân thành cảm ơn.

Tạo 1 cột phụ và dùng hàm Sumif là nhẹ rất nhiều

ChanhTQ@ · 7/10/17

Mình cho rằng 2 mảng là được rồi; 2 Dict là quá sang.

HieuCD · 7/10/17

Horse đã viết:
Em lấy biến K để xác định số hàng của mảng dArr anh ạ

Đa số trường hợp K = UBound(dArr), tính K chi cho rối

thinhnx22 · 9/10/17

Thực tế, file thật của mình còn nhiều dữ liệu khác nên muốn dùng code cho khỏe, cảm ơn tất cả anh chị đã góp ý và trợ giúp

Code thay thế sumproduct bằng VBA (1 người xem)

Người dùng đang xem chủ đề này

thinhnx22

Thành viên hoạt động

File đính kèm

Hoang2013

Thành viên gắn bó

thinhnx22

Thành viên hoạt động

Horse

Thành viên mới

thinhnx22

Thành viên hoạt động

ndu96081631

Huyền thoại GPE

HieuCD

Chuyên gia GPE

Horse

Thành viên mới

HieuCD

Chuyên gia GPE

File đính kèm

ChanhTQ@

0901452không62

HieuCD

Chuyên gia GPE

thinhnx22

Thành viên hoạt động

Bài viết mới nhất

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