Vấn đề tính hàng tổng cộng sau khi lọc và sum trong xử lý mảng

Liên hệ QC

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,570
Được thích
16,627
Giới tính
Nam
Tôi có một bảng dữ liệu, sau khi lọc duy nhất rồi cộng dồn theo cột, nhưng lại vướng là muốn thêm 1 hàng dưới cùng để làm hàng tổng cộng của các cột.

Xin vui lòng hướng dẫn.

PHP:
Private Sub SumDaTa()
    'On Error Resume Next
    Dim i As Long, iR As Long, iC As Long
    Dim sArray, Tmp, Arr()
    sArray = Range(Sheet2.[A1], Sheet2.[A65536].End(xlUp)).Resize(, 15)
    ReDim Arr(1 To UBound(sArray, 1), 1 To 15)
    iR = 0
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(sArray, 1)
            If sArray(i, 1) <> vbNullString Then
                Tmp = sArray(i, 1)
                If Not .Exists(Tmp) Then
                    iR = iR + 1
                    .Add Tmp, iR
                    Arr(iR, 1) = Tmp: Arr(iR, 2) = sArray(i, 2)
                    For iC = 3 To 15
                        Arr(iR, iC) = sArray(i, iC)
                    Next
                Else
                    For iC = 3 To 15
                        Arr(.Item(Tmp), iC) = Arr(.Item(Tmp), iC) + sArray(i, iC)
                    Next
                End If
            End If
        Next
    End With
    Sheet2.[R1].Resize(iR, 15).Value = Arr
End Sub
 

File đính kèm

  • SUM_ByARR.rar
    86.1 KB · Đọc: 27
Tôi có một bảng dữ liệu, sau khi lọc duy nhất rồi cộng dồn theo cột, nhưng lại vướng là muốn thêm 1 hàng dưới cùng để làm hàng tổng cộng của các cột.

Xin vui lòng hướng dẫn.

PHP:
Private Sub SumDaTa()
    'On Error Resume Next
    Dim i As Long, iR As Long, iC As Long
    Dim sArray, Tmp, Arr()
    sArray = Range(Sheet2.[A1], Sheet2.[A65536].End(xlUp)).Resize(, 15)
    ReDim Arr(1 To UBound(sArray, 1), 1 To 15)
    iR = 0
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(sArray, 1)
            If sArray(i, 1) <> vbNullString Then
                Tmp = sArray(i, 1)
                If Not .Exists(Tmp) Then
                    iR = iR + 1
                    .Add Tmp, iR
                    Arr(iR, 1) = Tmp: Arr(iR, 2) = sArray(i, 2)
                    For iC = 3 To 15
                        Arr(iR, iC) = sArray(i, iC)
                    Next
                Else
                    For iC = 3 To 15
                        Arr(.Item(Tmp), iC) = Arr(.Item(Tmp), iC) + sArray(i, iC)
                    Next
                End If
            End If
        Next
    End With
    Sheet2.[R1].Resize(iR, 15).Value = Arr
End Sub
Nếu không cần thể hiện côngt thức thì thêm tý mắm muối vào code
Mã:
Private Sub SumDaTa()
    'On Error Resume Next
    Dim i As Long, iR As Long, iC As Long, Tong
    Dim sArray, Tmp, Arr()
    sArray = Range(Sheet2.[A1], Sheet2.[A65536].End(xlUp)).Resize(, 15)
    ReDim Arr(1 To UBound(sArray, 1), 1 To 15)
    ReDim Tong(1 To 1, 2 To 15)
    Tong(1, 2) = "TONG CONG:"
    iR = 0
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(sArray, 1)
            If sArray(i, 1) <> vbNullString Then
                Tmp = sArray(i, 1)
                If Not .Exists(Tmp) Then
                    iR = iR + 1
                    .Add Tmp, iR
                    Arr(iR, 1) = Tmp: Arr(iR, 2) = sArray(i, 2)
                    For iC = 3 To 15
                        Arr(iR, iC) = sArray(i, iC)
                     If i > 1 Then Tong(1, iC) = Tong(1, iC) + sArray(i, iC)
                    Next
                Else
                    For iC = 3 To 15
                        Arr(.Item(Tmp), iC) = Arr(.Item(Tmp), iC) + sArray(i, iC)
                        Tong(1, iC) = Tong(1, iC) + sArray(i, iC)
                    Next
                End If
            End If
        Next
    End With
    Sheet2.[R1].Resize(iR, 15).Value = Arr
    [S1000].End(xlUp)(2).Resize(, 14) = Tong
End Sub
Híc
 
Upvote 0
Nếu không cần thể hiện côngt thức thì thêm tý mắm muối vào code
Mã:
    Sheet2.[R1].Resize(iR, 15).Value = Arr
    [S1000].End(xlUp)(2).Resize(, 14) = Tong
Híc

Hè hè, Bác Cò "chơi mánh" nhập 2 lần, OK, rất linh hoạt., "Khéo ăn thì no khéo co thì ấm".

Cám ơn Bác Cò nhé!
 
Upvote 0
Nếu không muốn gán 2 lần xuống sheet, thì thêm 1 Rờ-Dim nữa đúng không Bác Cò? hè hè.
Với code này, 64525 dòng và 54 cột đều có dữ liệu, chỉ mất gần 10 giây để thực hiện:

PHP:
Private Sub SumDaTa3()
    Dim i As Long, j As Long, k As Long, iR As Long, iC As Long
    Dim sArray, Tmp, Arr, Tong, GrossTotal
    sArray = Range(Sheet2.[A1], Sheet2.[A65536].End(xlUp)).Resize(, 54)
    ReDim Arr(1 To UBound(sArray, 1), 1 To 54)
    ReDim Tong(1 To 1, 1 To 54)
    Tong(1, 2) = "TONG CONG:"
    iR = 0
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(sArray, 1)
            If sArray(i, 1) <> vbNullString Then
                Tmp = sArray(i, 1)
                If Not .Exists(Tmp) Then
                    iR = iR + 1
                    .Add Tmp, iR
                    Arr(iR, 1) = Tmp: Arr(iR, 2) = sArray(i, 2)
                    For iC = 3 To 54
                        Arr(iR, iC) = sArray(i, iC)
                        If i > 1 Then Tong(1, iC) = Tong(1, iC) + sArray(i, iC)
                    Next
                Else
                    For iC = 3 To 54
                        Arr(.Item(Tmp), iC) = Arr(.Item(Tmp), iC) + sArray(i, iC)
                        Tong(1, iC) = Tong(1, iC) + sArray(i, iC)
                    Next
                End If
            End If
        Next
    End With
    j = iR + 1
    ReDim GrossTotal(1 To j, 1 To 54)
    For i = 1 To j
        For k = 1 To 54
            If i = j Then
                GrossTotal(i, k) = Tong(1, k)
            Else
                GrossTotal(i, k) = Arr(i, k)
            End If
        Next
    Next
    Sheet2.[BD1].Resize(j, 54).Value = GrossTotal
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom