怎么根据条件求和

tangyj

先将表格的B、C、D、E、F列按升序排序，如果B、C、D、E列有相同的行，对应的F列合并、G列合并，计算H列合计面积。
Sub MergeAndSumData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
   
    ' 遍历工作表
    For Each ws In ThisWorkbook.Worksheets
        ' 检查是否为需要操作的表格
        If ws.Name Like "b8" Then ' 将"Table*"替换为你要操作的表格的名称
            ' 获取最后一行数据
            lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
            
            ' 按B、C、D、E、F列按升序排序
            ws.Sort.SortFields.Clear
            ws.Sort.SortFields.Add Key:=Range("B3:B" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ws.Sort.SortFields.Add Key:=Range("C3:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ws.Sort.SortFields.Add Key:=Range("D3:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ws.Sort.SortFields.Add Key:=Range("E3:E" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ws.Sort.SortFields.Add Key:=Range("F3:F" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ws.Sort
                .SetRange Range("A3:I" & lastRow)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            ' 合并F列和G列相同的值
            For i = lastRow To 2 Step -1
                If ws.Cells(i, "B").Value = ws.Cells(i - 1, "B").Value And _
                   ws.Cells(i, "C").Value = ws.Cells(i - 1, "C").Value And _
                   ws.Cells(i, "D").Value = ws.Cells(i - 1, "D").Value And _
                   ws.Cells(i, "E").Value = ws.Cells(i - 1, "E").Value Then
                    ws.Cells(i, "F").Value = ws.Cells(i, "F").Value & ", " & ws.Cells(i - 1, "F").Value
                    ws.Cells(i, "G").Value = ws.Cells(i, "G").Value & ", " & ws.Cells(i - 1, "G").Value
                    ws.Rows(i - 1).Delete
                End If
            Next i
            
            ' 求合同一组B、C、D、E列的H列
            lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
            For i = lastRow To 2 Step -1
                If ws.Cells(i, "B").Value = ws.Cells(i - 1, "B").Value And _
                   ws.Cells(i, "C").Value = ws.Cells(i - 1, "C").Value And _
                   ws.Cells(i, "D").Value = ws.Cells(i - 1, "D").Value And _
                   ws.Cells(i, "E").Value = ws.Cells(i - 1, "E").Value Then
                    ws.Cells(i, "H").Value = ws.Cells(i, "H").Value + ws.Cells(i - 1, "H").Value
                    ws.Rows(i - 1).Delete
                End If
            Next i
            
        End If
    Next ws
End Sub

以上代码能实现按B、C、D、E合并F和G列值，但H列求和不正确！！！！

tangyj

自己顶一下

shiruiqiang

干嘛不字典多重嵌套？

shiruiqiang

你想分页汇总还是把所有的表格汇总？
代码分页汇总（原代码有点错误，已修正）

ykcbf1100

更新一下，加上排序功能

ykcbf1100

代码如下：

1. Sub ykcbf()  '//2023.12.18
   
2.     Dim arr, brr, d, s
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("b9")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .Range("a1:i" & r)
   
7.         For i = 4 To UBound(arr)
   
8.             s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
   
9.             If Not d.exists(s) Then
   
10.                 d(s) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 8))
    
11.             Else
    
12.                 t = d(s)
    
13.                 t(4) = t(4) & "、" & arr(i, 6)
    
14.                 t(5) = t(5) & "、" & arr(i, 7)
    
15.                 t(6) = t(6) + arr(i, 8)
    
16.                 d(s) = t
    
17.             End If
    
18.         Next
    
19.         t = d.items
    
20.         .[k3:q1000] = ""
    
21.         With .[k3].Resize(d.Count, 7)
    
22.             .Value = Application.Rept(d.items, 1)
    
23.             .Borders.LineStyle = 1
    
24.             .HorizontalAlignment = xlCenter
    
25.             .VerticalAlignment = xlCenter
    
26.         End With
    
27.     End With
    
28.     Set d = Nothing
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

yynrzwh

工作簿1.rar (318.26 KB, 下载次数: 21)

2023-12-18 21:17 上传

点击文件名下载附件

tangyj

谢谢各位大佬的帮助

tangyj

shiruiqiang 发表于 2023-12-18 20:52
你想分页汇总还是把所有的表格汇总？
代码分页汇总（原代码有点错误，已修正）

大佬，我只是需要针对b8表进行统计汇总，其他的表不变，你的这个代码把每个表都统计汇总了，怎么把你的这个代码修改成只针对一个表

tangyj

ykcbf1100 发表于 2023-12-18 20:53
代码如下：

感谢大佬指导代码