用VBA对有合并单元格的值求和并排序。

w01013086

表格里ABCDF都有不规则的合并单元格， 需要根据B列的合并，进行对G列的求和。并按合并的单元格，进行排序，详见附件，实在是复杂。谢谢帮忙

aman1516

1. 
   
2. Sub 求和()
   
3. Sheet1.Activate
   
4. Dim r&, i&, s&, k&, a&
   
5. On Error Resume Next
   
6. r = Cells(Rows.Count, 7).End(3).Row
   
7. For i = 2 To r
   
8.   If Cells(i, 2).MergeCells Then
   
9.      k = Cells(i, 2).MergeArea.Count
   
10.      Cells(i, 1).Resize(k, 6).Sort Cells(i, 7), 2
    
11.      Cells(i, 9) = "=SUM(G" & i & ":G" & i + k - 1 & ")"
    
12.      i = i + k - 1
    
13.   Else
    
14.      Cells(i, 9) = Cells(i, 7)
    
15.   End If
    
16. Next
    
17. End Sub

复制代码

aman1516

求和较简单，按G列排序稍复杂，第7~10行，30~32行，及40~50行等.....C、D列有不规则合并单元格，若非先拆分合并填充，排序后再合并，无法对应这些区域整行排序，静等高手有好方法

aman1516

猜想楼主应该是要按H列（I列，即求和列，格式同B列）进行排序吧，那就小问题了

zpy2

合并单元格的确是复杂的，建议经常这样的话还是取消合并单元格为好。

liangmutou01

如果不影响合并单元格，又要按G列排序，这是矛盾的。因为活动单元格所含的G列的数据就不一样，如何排？建议用I列排序，既然合并，说明是一类。

一把小刀闯天下

'没有好的方法，，，

'正好可以去看电视去

Option Explicit

Sub test()
  Dim i, j, k, sum, m, t, cnt
  Application.ScreenUpdating = False
  ReDim arr(1 To Cells(Rows.Count, "h").End(xlUp).Row, 1 To 3)
  For i = 2 To Cells(Rows.Count, "h").End(xlUp).Row
    If Cells(i, "b").MergeCells Then
      For j = i To i + Cells(i, "b").MergeArea.Rows.Count - 1
        sum = sum + Cells(j, "g")
      Next
      m = m + 1: arr(m, 1) = sum: arr(m, 2) = i: arr(m, 3) = j - 1
      Cells(i, "i") = sum: sum = 0
      i = j - 1
    Else
      Cells(i, "i") = Cells(i, "g")
      m = m + 1: arr(m, 1) = Cells(i, "g"): arr(m, 2) = i: arr(m, 3) = i
    End If
  Next
  For i = 1 To m - 1
    For j = i + 1 To m
      If arr(i, 1) < arr(j, 1) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
    Next
  Next
  [k1].Resize(Cells(Rows.Count, "h").End(xlUp).Row + 10, 10).Clear
  cnt = 2
  For i = 1 To m
    Cells(arr(i, 2), "a").Resize(arr(i, 3) - arr(i, 2) + 1, 9).Copy Cells(cnt, "k")
    Cells(cnt, "k") = i
    cnt = cnt + arr(i, 3) - arr(i, 2) + 1
  Next
  Application.ScreenUpdating = True
End Sub

一把小刀闯天下

'晕，又进入了审核模式。自己敲或者等吧，我看电视去啦，，，