ผลรวมย่อยในมาโครข้อมูลสด

คลิกขวาที่แท็บ sheet1 > ดูโค้ด

วางโค้ดนี้

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 4 Then
        If Target.Row = 4 Or Target.Row = 5 Or Target.Row = 6 Then Totals
    End If
End Sub

จากนั้นเพิ่ม module คลิกขวา Sheet1 ใน Project Explorer ใน VBE window และ Insert > Module
จากนั้นใส่รหัสนี้

Sub Totals()

    Range("C10:D" & Range("C10:C" & Rows.Count).End(xlDown).Row).ClearContents
    Dim startAtRow As Long
    startAtRow = 10 ' Set starting row
    Dim lr As Long, i As Long, j As Long
    lr = Range("J" & Rows.Count).End(xlUp).Row
    ReDim arr(lr - 4) As String
    For i = 5 To lr
        arr(i - 5) = Range("J" & i).Value
    Next i
    Dim arr2() As String
    arr2 = arr
    RemoveDuplicate arr
    For i = LBound(arr) To UBound(arr) - 1
        Range("C" & (i + startAtRow)).Value = arr(i)
        For j = LBound(arr2) To UBound(arr2) - 1
            If arr(i) = arr2(j) Then
                Range("D" & (i + startAtRow)).Value = Range("D" & i + startAtRow).Value + Range("I" & (j + 5)).Value
            End If
        Next j
    Next i

End Sub

Private Sub RemoveDuplicate(ByRef StringArray() As String)
    Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
    If (Not StringArray) = True Then Exit Sub
    lowBound = LBound(StringArray): UpBound = UBound(StringArray)
    ReDim tempArray(lowBound To UpBound)
    cur = lowBound: tempArray(cur) = StringArray(lowBound)
    For A = lowBound + 1 To UpBound
        For B = lowBound To cur
            If LenB(tempArray(B)) = LenB(StringArray(A)) Then
                If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
            End If
        Next B
        If B > cur Then cur = B: tempArray(cur) = StringArray(A)
    Next A
    ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub

ตอนนี้ทุกครั้งที่ผู้ใช้เปลี่ยนค่าของ D4,D5,D6 ผลลัพธ์ของคุณควรอัปเดต หมวดหมู่จะแสดงเริ่มต้นที่ C10 ลงมา และผลรวมจะแสดงที่ D10 ลงมา มีลักษณะเช่นนี้ ( เวอร์ชันตัวอย่าง )