Nhờ viết code tổng hợp dữ liệu.

Vunguyen87 · 18/8/21

Em xin chào tất cả các thành viên !
Em có bảng chấm công như file đính kèm ạ, lần trước em có nhờ các anh chị viết code in tự động và nhận được sự giúp đỡ nhiệt tình ạ. Hiện bảng này em đang tổng hợp với hàm excel, nhưng do dữ liệu nhiều nên máy tính xử lý rất lâu ạ. Em muốn nhờ anh chị viết giúp em code VBA cho sheet TONGHOP ạ.
- Tại sheet TONGHOP :
+ Cột A,B,C tổng hợp và lấy mã thẻ, tên, bộ phận của từng người từ cột A,B,C của sheet FILEDL.
+ Cột J đến cột Q tính tổng giờ làm tương ứng của mỗi người từ sheet FILEDL.
+ Cột W = L+M+N
+ Cột X =O+P
+ Cột Y= W+X
Em cảm ơn và mong nhận được sự giúp đỡ ạ !

Vunguyen87 · 18/8/21

Vunguyen87 đã viết:
Em xin chào tất cả các thành viên !
Em có bảng chấm công như file đính kèm ạ, lần trước em có nhờ các anh chị viết code in tự động và nhận được sự giúp đỡ nhiệt tình ạ. Hiện bảng này em đang tổng hợp với hàm excel, nhưng do dữ liệu nhiều nên máy tính xử lý rất lâu ạ. Em muốn nhờ anh chị viết giúp em code VBA cho sheet TONGHOP ạ.
- Tại sheet TONGHOP :
+ Cột A,B,C tổng hợp và lấy mã thẻ, tên, bộ phận của từng người từ cột A,B,C của sheet FILEDL.
+ Cột J đến cột Q tính tổng giờ làm tương ứng của mỗi người từ sheet FILEDL.
+ Cột W = L+M+N
+ Cột X =O+P
+ Cột Y= W+X
Em cảm ơn và mong nhận được sự giúp đỡ ạ !

Mong các anh chị viết giúp em code cho bài này ạ. Em cảm ơn !

Nhattanktnn · 18/8/21

Vunguyen87 đã viết:
Mong các anh chị viết giúp em code cho bài này ạ. Em cảm ơn !

Bạn thử :

Mã:

Option Explicit

Sub TongHopDuLieu()
Dim Dic As Object, sArr(), dArr()
Dim U1&, sU2&, dU2&, I&, J&, K&, sLr&, dLr&, ID$, Rws&
Const fSumCol = 10
Const lSumCol = 19
Application.ScreenUpdating = False
With Sheets("FILE DL")
    sLr = .Cells(Rows.Count, "A").End(xlUp).Row
    If sLr < 4 Then Exit Sub
    sArr = .Range("A4:T" & sLr).Value
    U1 = UBound(sArr): sU2 = UBound(sArr, 2)
End With
dU2 = sU2 + 5
Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To U1, 1 To dU2)
With Dic
    For I = 1 To U1
        ID = sArr(I, 1)
        If Not .exists(ID) Then
            K = K + 1
            .Add ID, K
            dArr(K, 1) = ID
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 3)
            Rws = K
        Else
            Rws = .Item(ID)
        End If
        For J = fSumCol To lSumCol
            dArr(Rws, J) = dArr(Rws, J) + sArr(I, J)
        Next
        dArr(Rws, 23) = dArr(Rws, 12) + dArr(Rws, 13) + dArr(Rws, 14)
        dArr(Rws, 24) = dArr(Rws, 15) + dArr(Rws, 16)
        dArr(Rws, 25) = dArr(Rws, 23) + dArr(Rws, 24)
    Next
End With
With Sheets("TONGHOP")
    dLr = .Cells(Rows.Count, "A").End(xlUp).Row
    If dLr > 6 Then .Rows("6:" & dLr - 1).Delete
    .Range("A4:Y5").ClearContents
    .Rows(5).Resize(K - 2).Insert
    .Range("A4").Resize(K, dU2) = dArr
End With
Set Dic = Nothing
Erase sArr, dArr
Application.ScreenUpdating = True
End Sub

Vunguyen87 · 19/8/21

Nhattanktnn đã viết:

Bạn thử :

Mã:

Option Explicit

Sub TongHopDuLieu()
Dim Dic As Object, sArr(), dArr()
Dim U1&, sU2&, dU2&, I&, J&, K&, sLr&, dLr&, ID$, Rws&
Const fSumCol = 10
Const lSumCol = 19
Application.ScreenUpdating = False
With Sheets("FILE DL")
    sLr = .Cells(Rows.Count, "A").End(xlUp).Row
    If sLr < 4 Then Exit Sub
    sArr = .Range("A4:T" & sLr).Value
    U1 = UBound(sArr): sU2 = UBound(sArr, 2)
End With
dU2 = sU2 + 5
Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To U1, 1 To dU2)
With Dic
    For I = 1 To U1
        ID = sArr(I, 1)
        If Not .exists(ID) Then
            K = K + 1
            .Add ID, K
            dArr(K, 1) = ID
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 3)
            Rws = K
        Else
            Rws = .Item(ID)
        End If
        For J = fSumCol To lSumCol
            dArr(Rws, J) = dArr(Rws, J) + sArr(I, J)
        Next
        dArr(Rws, 23) = dArr(Rws, 12) + dArr(Rws, 13) + dArr(Rws, 14)
        dArr(Rws, 24) = dArr(Rws, 15) + dArr(Rws, 16)
        dArr(Rws, 25) = dArr(Rws, 23) + dArr(Rws, 24)
    Next
End With
With Sheets("TONGHOP")
    dLr = .Cells(Rows.Count, "A").End(xlUp).Row
    If dLr > 6 Then .Rows("6:" & dLr - 1).Delete
    .Range("A4:Y5").ClearContents
    .Rows(5).Resize(K - 2).Insert
    .Range("A4").Resize(K, dU2) = dArr
End With
Set Dic = Nothing
Erase sArr, dArr
Application.ScreenUpdating = True
End Sub

Mình cảm ơn bạn !
File đã chạy như mình mong muốn rồi bạn nhé.

Cá ngừ F1 · 19/8/21

Thử code này xem sao:

Mã:

Sub GPE()
On Error Resume Next
Dim I&, K&, Dic As Object, Data(), TongHop(), Col(), J&, Itm
Data = Range(Sheets("FILE DL").[A4], Sheets("FILE DL").[A5000].End(3)).Resize(, 20)
Set Dic = CreateObject("Scripting.Dictionary")
ReDim TongHop(1 To UBound(Data), 1 To 25)
Col = Array(0, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
For I = 1 To UBound(Data)
    If Not Dic.exists(Data(I, 1)) Then
        K = K + 1
        Dic.Add Data(I, 1), K
        TongHop(K, 1) = Data(I, 1)
        TongHop(K, 2) = Data(I, 2)
        TongHop(K, 3) = Data(I, 3)
        For J = 1 To 10
            TongHop(K, Col(J)) = Data(I, Col(J))
        Next
    Else
        For J = 1 To 10
            Itm = Dic.Item(Data(I, 1))
            TongHop(Itm, Col(J)) = TongHop(Itm, Col(J)) + Data(I, Col(J))
        Next
    End If
    TongHop(Itm, 23) = TongHop(Itm, 12) + TongHop(Itm, 13) + TongHop(Itm, 14)
    TongHop(Itm, 24) = TongHop(Itm, 15) + TongHop(Itm, 16)
    TongHop(Itm, 25) = TongHop(Itm, 23) + TongHop(Itm, 24)
Next
Sheets("TONGHOP").[A4].Resize(I - 1, 25) = TongHop
End Sub

Code của bạn @Nhattanktnn tôi thấy ở Tổng hợp xuất hiện 2 mã trùng nhau: NS205214, Lê Đức Long.

Vunguyen87 · 23/8/21

Cá ngừ F1 đã viết:

Thử code này xem sao:

Mã:

Sub GPE()
On Error Resume Next
Dim I&, K&, Dic As Object, Data(), TongHop(), Col(), J&, Itm
Data = Range(Sheets("FILE DL").[A4], Sheets("FILE DL").[A5000].End(3)).Resize(, 20)
Set Dic = CreateObject("Scripting.Dictionary")
ReDim TongHop(1 To UBound(Data), 1 To 25)
Col = Array(0, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
For I = 1 To UBound(Data)
    If Not Dic.exists(Data(I, 1)) Then
        K = K + 1
        Dic.Add Data(I, 1), K
        TongHop(K, 1) = Data(I, 1)
        TongHop(K, 2) = Data(I, 2)
        TongHop(K, 3) = Data(I, 3)
        For J = 1 To 10
            TongHop(K, Col(J)) = Data(I, Col(J))
        Next
    Else
        For J = 1 To 10
            Itm = Dic.Item(Data(I, 1))
            TongHop(Itm, Col(J)) = TongHop(Itm, Col(J)) + Data(I, Col(J))
        Next
    End If
    TongHop(Itm, 23) = TongHop(Itm, 12) + TongHop(Itm, 13) + TongHop(Itm, 14)
    TongHop(Itm, 24) = TongHop(Itm, 15) + TongHop(Itm, 16)
    TongHop(Itm, 25) = TongHop(Itm, 23) + TongHop(Itm, 24)
Next
Sheets("TONGHOP").[A4].Resize(I - 1, 25) = TongHop
End Sub

Code của bạn @Nhattanktnn tôi thấy ở Tổng hợp xuất hiện 2 mã trùng nhau: NS205214, Lê Đức Long.

Mình cảm ơn bạn rất nhiều, nhưng mình vẫn chưa tìm ra mã nào trùng như bạn nói. Mình có chạy thử file dữ liệu của mình thì kết quả của bạn và bạn @Nhattanktnn giống nhau. Cảm ơn bạn đã giúp đỡ mình, mình sẽ dùng cả 2 code xem có phát hiện ra sự khác nhau không.

Nhờ viết code tổng hợp dữ liệu.

Vunguyen87

Thành viên mới

File đính kèm

Vunguyen87

Thành viên mới

Nhattanktnn

Thành viên gắn bó

File đính kèm

Vunguyen87

Thành viên mới

Cá ngừ F1

( ͡° ͜ʖ ͡°)

Vunguyen87

Thành viên mới

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