分类汇总

一把小刀闯天下

'假设C列有序，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, cnt, m, sum, total
  With Sheets("数据源")
    brr = .Range("b6:bd" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
  End With
  ReDim arr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
  For i = 1 To UBound(brr, 1) - 1
    For j = 4 To UBound(brr, 2)
      If brr(i, j) <> 0 Then Exit For
    Next
    If j < UBound(brr, 2) + 1 Then
      cnt = cnt + 1
      For j = 1 To UBound(brr, 2)
        arr(cnt, j) = brr(i, j)
      Next
    End If
  Next
  ReDim brr(1 To 2 * UBound(arr, 1), 1 To UBound(arr, 2)), sum(UBound(arr, 2)), total(UBound(arr, 2))
  For i = 1 To cnt
    m = m + 1: brr(m, 1) = i
    For j = 2 To UBound(arr, 2)
      brr(m, j) = arr(i, j)
      If j > 7 Then
        sum(j) = sum(j) + arr(i, j): total(j) = total(j) + arr(i, j)
      End If
    Next
    If arr(i, 2) <> arr(i + 1, 2) Then
      m = m + 2: brr(m - 1, 2) = "合计": brr(m, 2) = "累计"
      For j = 8 To UBound(arr, 2)
        brr(m - 1, j) = sum(j): brr(m, j) = total(j): sum(j) = 0
      Next
    End If
  Next
  With Sheets("结果表")
    .[b4].Resize(UBound(brr, 1) + 2, UBound(brr, 2)).Clear
    Sheets("数据源").[b4].Resize(2, UBound(brr, 2)).Copy .[b4]
    With .[b6].Resize(m, UBound(brr, 2))
      .Value = brr
      .Borders.LineStyle = xlContinuous
    End With
  End With
End Sub

ynymzzr

谢谢飞刀大师，感谢你的热情帮助。结果完全正确，可能是我没有表述清楚，就是不要结果表，直接在数据源表中得到结果。今天没有分了，明天补上，在次感谢，

ynymzzr

一把小刀闯天下 发表于 2020-1-15 15:32
'假设C列有序，，，

Option Explicit

感谢飞刀大师的帮助，结果正确，但是，可能是我没有表达清楚，就是不要结果表，在数据源表中直接得到结果，在次感谢帮助，今天没有分了明天补上。

3190496160

ynymzzr 发表于 2020-1-15 12:11
谢谢，感谢帮忙，可不可以在数据源表中实现，还有累计没有出来。

用6楼附件中的代码就可以生成累积了呀，你自己好好看看吧

一把小刀闯天下

'假设C列有序。稍作修改，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, m, cnt, sum
  With Sheets("数据源")
    brr = .Range("b6:bd" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
    ReDim arr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
    For i = 1 To UBound(brr, 1) - 1
      If brr(i, 2) <> "合计" And brr(i, 2) <> "累计" Then
        For j = 8 To UBound(brr, 2)
          If brr(i, j) <> 0 Then Exit For
        Next
        If j < UBound(brr, 2) + 1 Then
          cnt = cnt + 1
          For j = 1 To UBound(brr, 2)
            arr(cnt, j) = brr(i, j)
          Next
        End If
      End If
    Next
    ReDim brr(1 To 2 * UBound(arr, 1), 1 To UBound(arr, 2)), sum(1 To 2, UBound(arr, 2))
    For i = 1 To cnt
      m = m + 1: brr(m, 1) = i
      For j = 2 To UBound(arr, 2)
        brr(m, j) = arr(i, j)
        If j > 7 Then
          sum(1, j) = sum(1, j) + arr(i, j): sum(2, j) = sum(2, j) + arr(i, j)
        End If
      Next
      If arr(i, 2) <> arr(i + 1, 2) Then
        m = m + 2: brr(m - 1, 2) = "合计": brr(m, 2) = "累计"
        For j = 8 To UBound(arr, 2)
          brr(m - 1, j) = sum(1, j): brr(m, j) = sum(2, j): sum(1, j) = 0
        Next
      End If
    Next
    With .[b6].Resize(m, UBound(brr, 2))
      .Resize(UBound(brr, 1), UBound(brr, 2)).Clear
      .Borders.LineStyle = xlContinuous
      .Value = brr
    End With
    For i = 6 To 6 + m - 1
      If .Cells(i, "c") = "合计" Or .Cells(i, "c") = "累计" Then .Cells(i, "c").Resize(, 2).Merge
    Next
  End With
End Sub

ynymzzr

多谢，完美。

ynymzzr

老师，如果是无序大如何改动

一把小刀闯天下

ynymzzr 发表于 2020-1-16 12:38
老师，如果是无序大如何改动

'手工排序估计也用不了几秒。假设D列无序。按D列拼音升序，如果按出现次序进行排序需要加个字典，觉得按拼音排序会更直观点，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, m, cnt, sum
  With Sheets("数据源")
    brr = .Range("b6:bd" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
    ReDim arr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
    For i = 1 To UBound(brr, 1) - 1
      If brr(i, 2) <> "合计" And brr(i, 2) <> "累计" Then
        For j = 8 To UBound(brr, 2)
          If brr(i, j) <> 0 Then Exit For
        Next
        If j < UBound(brr, 2) + 1 Then
          cnt = cnt + 1
          For j = 1 To UBound(brr, 2)
            arr(cnt, j) = brr(i, j)
          Next
        End If
      End If
    Next
    ReDim brr(1 To 2 * UBound(arr, 1), 1 To UBound(arr, 2)), sum(1 To 2, UBound(arr, 2))
    Call qsort(arr, 1, cnt, 1, UBound(arr, 2), 2)
    For i = 1 To cnt
      m = m + 1: brr(m, 1) = i
      For j = 2 To UBound(arr, 2)
        brr(m, j) = arr(i, j)
        If j > 7 Then
          sum(1, j) = sum(1, j) + arr(i, j): sum(2, j) = sum(2, j) + arr(i, j)
        End If
      Next
      If arr(i, 2) <> arr(i + 1, 2) Then
        m = m + 2: brr(m - 1, 2) = "合计": brr(m, 2) = "累计"
        For j = 8 To UBound(arr, 2)
          brr(m - 1, j) = sum(1, j): brr(m, j) = sum(2, j): sum(1, j) = 0
        Next
      End If
    Next
    With .[b6].Resize(m, UBound(brr, 2))
      .Resize(UBound(brr, 1), UBound(brr, 2)).Clear
      .Borders.LineStyle = xlContinuous
      .Value = brr
    End With
    For i = 6 To 6 + m - 1
      If .Cells(i, "c") = "合计" Or .Cells(i, "c") = "累计" Then .Cells(i, "c").Resize(, 2).Merge
    Next
  End With
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x As String, t As String
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
    While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

ynymzzr

谢谢老师回复