我在excel中有以下数据：
+------+-------+-------+----+
| name | count | net | CD |
+------+-------+-------+----+
| c1 | 125 | 12500 | D |
| c2 | 55 | 3500 | C |
| c3 | 80 | 2599 | C |
| c4 | 30 | 1500 | D |
| DGPS | 45 | 1000 | D |
| | | | |
| PART | 51 | 1560 | C |
| DGPS | 20 | 1990 | D |
| c2 | 25 | 1325 | C |
| | | | |
| c3 | 15 | 4500 | C |
| c1 | 25 | 6300 | D |
| | | | |
+------+-------+-------+----+
我不需要以DGPS，PART开头或为空的行，因此我必须将其删除。然后，我需要执行求和和分组。首先，如果CD = D，我需要将net转换为-net。然后尝试按名称获取名称，sum（count），sum（net）组。然后最后检查sum（net）> 0，然后CD = C； sum（net）<0，然后CD = D。
我可以在sql中使用以下查询：
select name,sum(count),to_char(ABS(ROUND(sum(net),2))),CASE when sum(net) > 0 then 'C' when sum(net) < 0 then 'D' when sum(net) = 0 then '0' END AS CD
FROM
(SELECT name,count,CASE WHEN CD = 'C' THEN to_char(ROUND(net,2)) ELSE to_char(ROUND(-net,2)) END AS net
FROM tb1
)
group by name order by upper(name);
但是我不允许使用外部数据库或库，因此不能使用sql-adodb。但我希望，由于这是一个简单的求和和分组，因此我们可以仅使用vba而不使用sql来实现。
编辑：示例最终输出格式
+------+-------+-------+----+
| name | count | net | CD |
+------+-------+-------+----+
| c1 | 150 | 18800 | D |
| c2 | 80 | 4825 | C |
| c3 | 95 | 7099 | C |
| c4 | 30 | 1500 | D |
+------+-------+-------+----+
答案 0 :(得分：2)
大概是这样的：
Option Explicit
Public Sub SpecialSum()
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("data")
Dim wsOutput As Worksheet
Set wsOutput = ThisWorkbook.Worksheets("output")
Dim AllNames As Variant
AllNames = wsData.Range("A2", wsData.Cells(wsData.Rows.Count, "A").End(xlUp)).Value
Dim UniqueNames As Object
Set UniqueNames = CreateObject("Scripting.Dictionary")
Dim iRow As Long
For iRow = 1 To UBound(AllNames, 1)
If AllNames(iRow, 1) <> "DGPS" And AllNames(iRow, 1) <> "PART" And AllNames(iRow, 1) <> "" Then
If Not UniqueNames.Exists(AllNames(iRow, 1)) Then
UniqueNames.Add AllNames(iRow, 1), 1
End If
End If
Next iRow
ReDim AllNames(1 To UniqueNames.Count, 1 To 1) As String
iRow = 1
Dim Key As Variant
For Each Key In UniqueNames.Keys
AllNames(iRow, 1) = Key
iRow = iRow + 1
Next Key
wsOutput.Rows(1).Value = wsData.Rows(1).Value
wsOutput.Range("A2").Resize(RowSize:=UniqueNames.Count).Value = AllNames
wsOutput.Range("B2").Resize(RowSize:=UniqueNames.Count).Formula = "=SUMIF('" & wsData.Name & "'!A:A,'" & wsOutput.Name & "'!A:A,'" & wsData.Name & "'!B:B)"
wsOutput.Range("C2").Resize(RowSize:=UniqueNames.Count).Formula = "=ABS(SUMIFS('" & wsData.Name & "'!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=C"")-SUMIFS(data!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=D""))"
wsOutput.Range("D2").Resize(RowSize:=UniqueNames.Count).Formula = "=IF(SUMIFS('" & wsData.Name & "'!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=C"")-SUMIFS(data!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=D"")<0,""D"", ""C"")"
End Sub
答案 1 :(得分：1)
如果使用Windows版Excel，请考虑使用SQL。下面显示了使用ODBC的驱动程序和使用OLEDB的提供程序的连接字符串。但是，您当前的看起来像Oracle方言的SQL必须转换为Jet / ACE SQL方言（MS Access的所有引擎）。另外，下面假设您的数据保留标题，并从A1的最左上角单元格开始，并命名为 RESULTS 的空白工作表用于查询输出。
SQL （在下面的VBA字符串中使用，在FROM中调整SheetName）
SELECT agg.[name],
agg.sum_count AS [count],
agg.sum_net AS [net],
IIF(sub.sum_net > 0, 'C',
IIF(sub.sum_net < 0, 'D', '0')
) AS [CD]
FROM
(SELECT s.[name],
SUM(s.[count]) AS sum_count,
SUM(IIF(CD = 'C', ROUND(net,2), ROUND(net,2) * -1)) AS sum_net
FROM [SheetName$] s
WHERE INSTR(s.[name], 'DGPS') = 0 OR INSTR(s.[name], 'PART') = 0
GROUP BY s.[name]
) AS agg
ORDER BY UCASE(agg.[name]);
VBA （无循环或逻辑）
Sub RunSQL()
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim LastRow As Integer
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' TWO CONNECTION STRINGS FOR DRIVER OR PROVIDER
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=" & ThisWorkbook.FullName & ";"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='" & ThisWorkbook.FullName & "';" _
& "Extended Properties=""Excel 12.0;HDR=YES;"";"
' OPEN DB CONNECTION
conn.Open strConnection
' OPEN QUERY RECORDSET
strSQL = "SELECT agg.[name], " _
& " agg.sum_count AS [count], " _
& " agg.sum_net AS [net], " _
& " IIF(sub.sum_net > 0, 'C', " _
& " IIF(sub.sum_net < 0, 'D', '0') " _
& " ) AS [CD] " _
& " FROM " _
& " (SELECT s.[name], " _
& " SUM(s.[count]) AS sum_count, " _
& " SUM(IIF(CD = 'C', ROUND(net,2), ROUND(net,2) * -1)) AS sum_net " _
& " FROM [SheetName$] s " _
& " WHERE INSTR(s.[name], 'DGPS') = 0 OR INSTR(s.[name], 'PART') = 0 " _
& " GROUP BY s.[name] " _
& " ) AS agg " _
& " ORDER BY UCASE(agg.[name]);"
rst.Open strSQL, conn
' COPY DATA TO WORKSHEET
Worksheets("RESULTS").Range("A2").CopyFromRecordset rst
rst.Close: conn.Close
Set rst = Nothing: Set conn = Nothing
End Sub
答案 2 :(得分：0)
Result”）
在ThisWorkbook中，即包含此代码的工作簿中。Const）部分中的值。CSV复制数据，
必须将cEnableCSV设置为True并将cCsv更改为
打开 CSV文件，包括扩展名，例如“ 总和
Group.csv ”。CSV的麻烦，请查看我的帖子CSV
Nightmare。Option Explicit
Sub MagicSort()
' Note: Do not remove the first comma, because it will include "" into
' the array.
Const cExceptions As String = ",DGPS,PART" ' Exception List
Const cSheet As String = "Sheet1" ' Source Worksheet Name
Const cTarget As String = "Result" ' Target Worksheet Name
Const cCols As String = "A:D" ' Source Columns Range Address
Const cHeaders As Long = 1 ' Source Header Row Number
Const cFcell As String = "A1" ' Target First Cell Address
' CSV
Const cCsv As String = "Sum Group.csv" ' Source CSV Name
Const cEnableCSV As Boolean = False ' CSV Enabler, True: enable CSV.
Dim wsT As Worksheet ' Target Worksheet
Dim rng As Range ' Init Last Used Cell Range,
' Init Range
Dim dict As Object ' Source Dictionary
Dim key As Variant ' Dictionary Key
Dim vntI As Variant ' Init Array
Dim vntE As Variant ' Exception Array
Dim vntS As Variant ' Source Array
Dim NorI As Long ' Init Number of Rows
Dim Noe As Long ' Number of Exceptions - 1 (0-based array)
Dim NorS As Long ' Source Number of Rows
Dim NorT As Long ' Target Number of Rows
Dim Noc As Long ' (Init/Source) Number of Columns
Dim i As Long ' Init Row Counter
Dim j As Long ' Column Counter
Dim k As Long ' Source Row Counter
Dim m As Long ' Exception Element Counter
Dim currV As Variant ' Current Value (in 1st, 2nd Column)
' Task: Copy all data sorted to Init Array.
With ThisWorkbook
' Delete Target Worksheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
.Worksheets(cTarget).Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Check value of CSVEnabler.
If cEnableCSV Then
' Create a copy of Source CSV as Target Worksheet.
Windows(cCsv).ActiveSheet.Copy After:=.Worksheets(.Sheets.Count)
Else
' Create a copy of Source Worksheet as Target Worksheet.
.Worksheets(cSheet).Copy After:=.Worksheets(.Sheets.Count)
End If
' Create a reference to Target Worksheet.
Set wsT = ActiveSheet
' Rename Target Worksheet.
wsT.Name = cTarget
End With
' In Target Worksheet
With wsT.Columns(cCols)
' Calculate and create a reference to Source Last Used Cell Range.
Set rng = .Resize(, 1).Find("*", , xlFormulas, , , xlPrevious)
' Calculate and create a reference to Init Range.
Set rng = .Rows(cHeaders).Resize(rng.Row - cHeaders + 1)
' Sort Init Range.
rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
End With
' Write number of rows in Init Range to Init Number of Rows.
NorI = rng.Rows.Count
' Write number of columns in Init Range to Number of Columns.
Noc = rng.Columns.Count
' Copy Init Range to Init Array.
vntI = rng
' Task: Count Source Number of Rows.
' Write Exception List to Exception Array.
vntE = Split(cExceptions, ",")
' Write number of elements in Exception Array to Number of Exceptions - 1.
Noe = UBound(vntE)
' Loop through rows in 1st column of Init Array.
For i = 1 To NorI
' Write current element of Init Array to Current Value.
currV = Trim(vntI(i, 1))
' Loop through elements of Exception Array.
For m = 0 To Noe
' Check if value of current element in Init Array is different
' than value of current element in Exception Array.
If currV = vntE(m) Then Exit For
Next
' Check if match was not found.
If m = Noe + 1 Then
' Count Source Row.
k = k + 1
End If
Next
' Write current value of Source Row Counter to Source Number of Rows.
NorS = k
' Task: Write 'cleaned' data to Source Array.
' Resize Source Array to Source Number of Rows by Number of Columns.
ReDim vntS(1 To NorS, 1 To Noc)
' Reset Source Row Counter
k = 0
' Loop through rows of Init Array.
For i = 1 To NorI
' Write current element of Init Array to Current Value.
currV = Trim(vntI(i, 1))
' Loop through elements of Exception Array.
For m = 0 To Noe
' Check if value of current element in Init Array is different
' than value of current element in Exception Array.
If currV = vntE(m) Then Exit For
Next
' Check if match was not found.
If m = Noe + 1 Then
' Count Source Row.
k = k + 1
' Loop through columns (of Init/Source Array).
For j = 1 To Noc
' Write current value from Init Array to current element
' of Source Array.
vntS(k, j) = vntI(i, j)
Next
End If
Next
' Erase not needed arrays.
Erase vntI
Erase vntE
' Task: Perform calculations and write to Target Array.
For k = 1 To NorS
If Trim(vntS(k, 4)) = "D" Then vntS(k, 3) = -vntS(k, 3)
Next
' Create a reference to Source Dictionary.
Set dict = CreateObject("Scripting.Dictionary")
' Loop through elements (rows) of Source Array.
For k = 2 To NorS
' Write element in current row (i) in 2nd column of Source Array (vntS)
' to Current Value.
currV = vntS(k, 2)
' Check if Current Value (CurV) is NOT a number.
If Not IsNumeric(currV) Then
' Assign 0 to Current Value.
currV = 0
End If
' Add current element (row) in Source Array (vntS) and Current Value
' to the Dictionary. If the key to be added is new (not existing),
' the new key and the item will be added. But if the key exists, then
' the existing item will be increased by the value of the new item.
' This could be called "The Dictionary SumIf Feature".
dict(vntS(k, 1)) = dict(vntS(k, 1)) + currV
Next
' Write Number of keys in Source Dictionary + 1 for Headers to Target
' Number of Rows.
NorT = dict.Count + 1 ' + 1 for headers.
' Resize Target Array to Target Number of Rows and Number of Columns.
ReDim vntT(1 To NorT, 1 To Noc)
' Write Headers from Source to Target Array's first row.
For j = 1 To Noc
vntT(1, j) = vntS(1, j)
Next
' Reset Dictionary (Row) Counter.
i = 1
For Each key In dict.Keys
' Count Dictionary Key.
i = i + 1
' Write Dictionary Key to 1st column Target Array.
vntT(i, 1) = key
' Write Dictionary Value to 2nd column Target Array.
vntT(i, 2) = dict(key)
Next
' Clear Source Dictionary.
dict.RemoveAll
' Loop through elements (rows) of Source Array.
For k = 2 To NorS
' Write element in current row (i) in 2nd column of Source Array (vntS)
' to Current Value.
currV = vntS(k, 3)
' Check if Current Value (CurV) is NOT a number.
If Not IsNumeric(currV) Then
' Assign 0 to Current Value.
currV = 0
End If
' Add current element (row) in Source Array (vntS) and Current Value
' to the Dictionary. If the key to be added is new (not existing),
' the new key and the item will be added. But if the key exists, then
' the existing item will be increased by the value of the new item.
' This could be called "The Dictionary SumIf Feature".
dict(vntS(k, 1)) = dict(vntS(k, 1)) + currV
Next
' Erase not needed arrays.
Erase vntS
' Reset Dictionary (Row) Counter.
i = 1
For Each key In dict.Keys
' Count Dictionary Key.
i = i + 1
' Write Dictionary Key to 1st column Target Array.
vntT(i, 1) = key
' Write Dictionary Value to 2nd column Target Array.
vntT(i, 3) = dict(key)
Next
' Clear Source Dictionary.
dict.RemoveAll
' Calculate 3rd and 4th column.
For k = 2 To NorT
If vntT(k, 3) > 0 Then
vntT(k, 4) = "C"
Else
vntT(k, 4) = "D"
vntT(k, 3) = -vntT(k, 3)
End If
Next
' For j = 1 To Noc
' For i = 1 To NorT
' Debug.Print vntT(i, j)
' Next
' Next
With ThisWorkbook.Worksheets(cTarget)
.Cells.ClearContents
Set rng = .Range(cFcell).Resize(NorT, Noc)
End With
rng.Value = vntT
' Apply Formatting
With rng
' Apply formatting to whole Target Range.
.Columns.AutoFit
' ' Apply formatting to Headers only:
' With .Rows(1)
'
' End With
' ' Apply formatting to Body (Data) only:
' With .Rows(1).Offset(1).Resize(Rows.Count - 1)
'
' End With
End With
End Sub