Excel VBA脚本进行筛选和求和

我正在使用下面的代码，它的作用是过滤唯一的名称和总值字段。 我最近需要扩展对唯一名称的过滤，以在条件中包含其他列。 请参阅我正在寻找的示例输出。 任何帮助，将不胜感激。

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，然后我下面的代码应该工作。 请让我知道这对你有没有用。

 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 

结束function

Answer 2

我在Excel 2016中使用数据透视表来生成这个视图，因为你不反对使用数据透视表。 如果Excel可以开箱即用，而且您对它的外观和行为感到满意，那么在这种情况下就不需要定制的VBA了。

只要做到以下几点：

• 突出显示您的数据，然后插入>数据透视表
  • 我把数据透视表放在Sheet 1的单元格F1中
• 将名称，代码和date添加到数据透视表的行
• 将值添加到数据透视表的值。 它应该默认为Sum。
• 点击数据透视表，然后在function区数据透视表工具>devise选项卡中，转到“布局”function区组：
  • 在报告版面下拉菜单上：
    • 点击“以表格forms显示”
    • 点击“重复所有项目标签”
  • 在小计下拉菜单中：
    • 点击“不显示分类汇总”
  • 总计下拉菜单：
    • 点击“closures行和列”

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