Lấy tên theo danh sách

[Phamanh1998]

Em chào cả nhà. Em có một vấn đề này mong được anh/chị hỗ trợ ạ.
Em có một sách tên các nhân viên và số lượng sản phẩm bán ra trong một ngày. (Một tên chỉ tồn tại duy nhất 1 giá trị theo dòng tương ứng. VD Sheet Data dòng số 2 thì tên Xuân chỉ xuất hiện 1 lần duy nhất).
Em hiện nay đang dùng công thức thì thấy file chạy chậm ạ. Em mong anh chị có thể giúp em phần Code VBA giải quyết vấn đề trên thay vì làm bằng công thức ạ.
Em cảm ơn anh chị nhiều ạ

 

[Ba Tê]

Em chào cả nhà. Em có một vấn đề này mong được anh/chị hỗ trợ ạ.
Em có một sách tên các nhân viên và số lượng sản phẩm bán ra trong một ngày. (Một tên chỉ tồn tại duy nhất 1 giá trị theo dòng tương ứng. VD Sheet Data dòng số 2 thì tên Xuân chỉ xuất hiện 1 lần duy nhất).
Em hiện nay đang dùng công thức thì thấy file chạy chậm ạ. Em mong anh chị có thể giúp em phần Code VBA giải quyết vấn đề trên thay vì làm bằng công thức ạ.
Em cảm ơn anh chị nhiều ạ

Tạo một Module, chép Sub này vào rồi chạy thử xem sao.
B25 "Chi", F25 "Chi " là 2 người khác nhau?

Option Explicit

Public Sub GPE()
Dim Dic As Object, sArr(), fDay As Long, eDay As Long
Dim dArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Ten As String
Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheets("Result").Range("A2", Sheets("Result").Range("A2").End(xlDown)).Resize(, 7).Value
    Rws = UBound(sArr)
ReDim dArr(1 To Rws, 1 To 2)
With Sheets("Data")
    fDay = .Range("B1").Value
    eDay = .Range("B2").Value
    For I = 1 To Rws
        If sArr(I, 1) >= fDay Then
            If sArr(I, 1) <= eDay Then
                For J = 2 To 6
                    Ten = sArr(I, J)
                    If Not Dic.Exists(Ten) Then
                        K = K + 1
                        Dic.Item(Ten) = K
                        dArr(K, 1) = Ten
                        dArr(K, 2) = sArr(I, 7)
                    Else
                        R = Dic.Item(Ten)
                        dArr(R, 2) = dArr(R, 2) + sArr(I, 7)
                    End If
                Next J
            End If
        End If
    Next I
    .Range("D5:E1000").ClearContents
    .Range("D5").Resize(K, 2) = dArr
End With
Set Dic = Nothing
End Sub

 

[Phamanh1998]

Tạo một Module, chép Sub này vào rồi chạy thử xem sao.
B25 "Chi", F25 "Chi " là 2 người khác nhau?

Option Explicit

Public Sub GPE()
Dim Dic As Object, sArr(), fDay As Long, eDay As Long
Dim dArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Ten As String
Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheets("Result").Range("A2", Sheets("Result").Range("A2").End(xlDown)).Resize(, 7).Value
    Rws = UBound(sArr)
ReDim dArr(1 To Rws, 1 To 2)
With Sheets("Data")
    fDay = .Range("B1").Value
    eDay = .Range("B2").Value
    For I = 1 To Rws
        If sArr(I, 1) >= fDay Then
            If sArr(I, 1) <= eDay Then
                For J = 2 To 6
                    Ten = sArr(I, J)
                    If Not Dic.Exists(Ten) Then
                        K = K + 1
                        Dic.Item(Ten) = K
                        dArr(K, 1) = Ten
                        dArr(K, 2) = sArr(I, 7)
                    Else
                        R = Dic.Item(Ten)
                        dArr(R, 2) = dArr(R, 2) + sArr(I, 7)
                    End If
                Next J
            End If
        End If
    Next I
    .Range("D5:E1000").ClearContents
    .Range("D5").Resize(K, 2) = dArr
End With
Set Dic = Nothing
End Sub

Em cảm ơn anh ạ, bài toán của em đã được giải quyết ạ

 

[vanthinh3101]

Em chào cả nhà. Em có một vấn đề này mong được anh/chị hỗ trợ ạ.
Em có một sách tên các nhân viên và số lượng sản phẩm bán ra trong một ngày. (Một tên chỉ tồn tại duy nhất 1 giá trị theo dòng tương ứng. VD Sheet Data dòng số 2 thì tên Xuân chỉ xuất hiện 1 lần duy nhất).
Em hiện nay đang dùng công thức thì thấy file chạy chậm ạ. Em mong anh chị có thể giúp em phần Code VBA giải quyết vấn đề trên thay vì làm bằng công thức ạ.
Em cảm ơn anh chị nhiều ạ

Góp vui.
Sử dụng Power Query, kết hợp Sự kiện Worksheet_Change của VBA.
Khi bạn thay đổi thông tin ngày tháng tại ô A2 hoặc B2, kết quả được tự động cập nhật.
Chi tiết theo file đính kèm.