Excel VBA腳本進行過濾和求和

Question

我正在使用下面的代碼，它可用於過濾唯一名稱和總計值字段。 最近，我需要擴展唯一名稱的過濾，以在條件中包括其他列。 請查看我正在尋找的示例輸出。 任何幫助，將不勝感激。

 Sub SUM()

  Dim i, j, k As Integer
   i = 2
   j = 2

Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"

'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value

'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""

    'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
    'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
    'in column D and E
    If Range("A" & i).Value = Range("A" & i - 1).Value Then
        Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
    Else
        flag = 1
        While Range("D" & flag).Value <> ""
            If Range("A" & i).Value = Range("D" & flag).Value Then
                j = flag
                Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
                flag = Range("D1").End(xlDown).Row
            Else
                j = 0
            End If
            flag = flag + 1
        Wend
        If j = 0 Then
            Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
            Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
            j = Range("E1").End(xlDown).Row
        End If
    End If

    i = i + 1
Wend
MsgBox "End"

End Sub

當前輸出如下：

 Name  Value       Name    Sum
    A           1       A     13
    A           2       B      7
    B           1       C      3
    B           3           
    C           2           
    A           1           
    B           2           
    A           3           
    B           1           
    A           2           
    A           4           
    C           1      

我希望它像下面的示例那樣導出數據：

Name  Code  Date     Value       Name   Code  Date   Sum
   A   101  3/10/17      1       A     101   3/10/17    9
   A   101  3/10/17      2       A     102   3/10/17    4
   B   102  3/10/17      1       B     101   3/10/17    3
   B   101  3/10/17      3       B     102   3/10/17    2
   C   102  3/8/17       2       B     101   3/8/17     2
   A   102  3/10/17      1       C     102   3/8/17     2
   B   101  3/8/17       2       C     102   3/10/17    1   
   A   102  3/10/17      3         
   B   102  3/10/17      1           
   A   101  3/10/17      2           
   A   101  3/10/17      4           
   C   102  3/10/17      1           

Answer 1

只要您的列依次為A，B，C，D，然后按F，G，H，I，則下面的代碼就應該起作用。 請讓我知道這對你有沒有用。

Sub CountCodes()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim wbk As Workbook
Dim ws As Worksheet
Dim wsRow As Long, newRow As Long
Dim Names() As String
Dim Found As Boolean
Dim x As Integer, y As Integer, z As Integer, myCount As Integer, mySum As Integer
Dim Cell As Range

Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)

ReDim Names(0 To 0) As String
ReDim Codes(0 To 0) As String
ReDim Dates(0 To 0) As String

newRow = 1

With ws
    'Find last row of data
    wsRow = .Range("A" & .Rows.Count).End(xlUp).Row

    'Loop through Column A to fill array
    For Each Cell In .Range(.Cells(2, 1), .Cells(wsRow, 1))
        'Fill Names array
        Found = (IsInArray(Cell.Value2, Names) > -1)
        If Found = False Then
            Names(UBound(Names)) = Cell.Value2
            If Cell.Row <> wsRow Then
                ReDim Preserve Names(0 To UBound(Names) + 1) As String
            End If
        End If

        'Fill Codes array
        Found = (IsInArray(Cell.Offset(0, 1).Value2, Codes) > -1)
        If Found = False Then
            Codes(UBound(Codes)) = Cell.Offset(0, 1).Value2
            If Cell.Row <> wsRow Then
                ReDim Preserve Codes(0 To UBound(Codes) + 1) As String
            End If
        End If

        'Fill Dates array
        Found = (IsInArray(Cell.Offset(0, 2).Value2, Codes) > -1)
        If Found = False Then
            Dates(UBound(Dates)) = Cell.Offset(0, 2).Value
            If Cell.Row <> wsRow Then
                ReDim Preserve Codes(0 To UBound(Dates) + 1) As String
            End If
        End If
    Next
    'Add Autofilter if off
    If .AutoFilterMode = False Then
        .Range("A1").AutoFilter
    End If

    For x = LBound(Names) To UBound(Names)
        .Range("A1").AutoFilter Field:=1, Criteria1:=Names(x)
        For y = LBound(Codes) To UBound(Codes)
            .Range("B1").AutoFilter Field:=2, Criteria1:=Codes(y)
            For z = LBound(Dates) To UBound(Dates)
                .Range("C1").AutoFilter Field:=3, Criteria1:=Dates(z)
                For Each Cell In .Range("A1:A" & wsRow).SpecialCells(xlCellTypeVisible)
                    myCount = myCount + 1
                Next
                If myCount > 1 Then
                    For Each Cell In .Range("D2:D" & wsRow).SpecialCells(xlCellTypeVisible)
                        mySum = mySum + Cell.Value2
                    Next
                    'Find last row in new data
                    newRow = newRow + 1
                    .Cells(newRow, 6) = Names(x)
                    .Cells(newRow, 7) = Codes(y)
                    .Cells(newRow, 8) = Dates(z)
                    .Cells(newRow, 9) = mySum
                End If
                myCount = 0
                mySum = 0
            Next z
        Next y
    Next x
    .ShowAllData
End With

Erase Names
Erase Codes
Erase Dates

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Long
'http://stackoverflow.com/questions/10951687/how-to-search-for-string-in-an-array
'Boolean = (IsInArray(StringToFind, ArrayToSearch) > -1)
    Dim i As Long
    ' default return value if value not found in array
    IsInArray = -1

For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
        IsInArray = i
        Exit For
    End If
Next i

結束功能

Answer 2

由於您不反對使用數據透視表，因此我在Excel 2016中使用了數據透視表來生成此視圖。 如果Excel可以開箱即用，並且您對它的外觀和行為感到滿意，那么在這種情況下就不需要自定義VBA。

只需執行以下操作：

• 突出顯示您的數據，然后插入>數據透視表
  • 我將數據透視表放置在工作表1的單元格F1中
• 將名稱，代碼和日期添加到數據透視表的行中
• 將值添加到數據透視表的值。 它應默認為Sum。
• 單擊數據透視表，然后在功能區的數據透視表工具>設計選項卡中，轉到“布局”功能區組：
  • 在“報表布局”下拉列表中：
    • 單擊“以表格形式顯示”
    • 單擊“重復所有項目標簽”
  • 在小計下拉列表中：
    • 單擊“不顯示小計”
  • 在總計下拉列表中：
    • 單擊“關閉以獲取行和列”

Answer 3

您可以使用Dictionary對象：

Option Explicit

Sub ListTotals()
    Dim c As Range, dataRng As Range
    Dim key As Variant

    Set dataRng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
    With CreateObject("Scripting.Dictionary")
        For Each c In dataRng
            key = Join(c.Resize(,3), "|")
            .Item(key) = .Item(key) + c.Offset(,4)
        Next c

        With dataRng.Resize(.Count)
            .Offset(,5) = Application.Transpose(.Keys)
            .Offset(,8) = Application.Transpose(.Items)
            .Offset(,5).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|", FieldInfo:= Array(Array(1, 2), Array(3, 3))
        End With
    End With
End Sub