有合并单元格B列跟C列数据由最大到最小同时D列加总VBA

jylai

B7:C11目前排顺序是错的，正确排序要像 G1:H5

B12:C13目前排顺序是错的，正确排序要像 G8:H9

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, i&, p&
   
    With [A1].CurrentRegion.Offset(1)
        p = 1
        ar = .Value
        For i = 1 To UBound(ar) - 1
            If Len(ar(i, 1)) = False Then ar(i, 1) = ar(i - 1, 1)
        Next i
        For i = 1 To UBound(ar) - 1
            If ar(i + 1, 1) <> ar(p, 1) Then
                With .Cells(p, 2).Resize(i - p + 1, 2)
                    br = .Value
                    bSort br, 1, UBound(br), 1, 2, 2, False
                    .Value = br
                    p = i + 1
                End With
            End If
        Next i
    End With
End Sub

Function bSort(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k)
                        ar(j, k) = ar(j + 1, k)
                        ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

。。。。。。。。。。

ykcbf1100

排序。。。。。

ykcbf1100

按合并单元格数量排序

1. Sub ykcbf()  '//2024.8.14
   
2.     r = Cells(Rows.Count, 3).End(3).Row
   
3.     For i = 2 To r
   
4.         m = Cells(i, 1).MergeArea.Count
   
5.         Set Rng = Cells(i, 2).Resize(m, 2)
   
6.         Rng.Sort Rng.Cells(1, 2), 2
   
7.         i = i + m - 1
   
8.     Next
   
9.     MsgBox "OK！"
   
10. End Sub
    

复制代码

jylai

gwjkkkkk 发表于 2024-8-14 20:05
。。。。。。。。。。

老师D列还没有做加总呢？

jylai

ykcbf1100 发表于 2024-8-14 20:30
按合并单元格数量排序

老师D列还没有做加总呢？

ykcbf1100

jylai 发表于 2024-8-15 08:12
老师D列还没有做加总呢？

被你的效果图误导，你效果图中就没有汇总。

改一下吧。

ykcbf1100

汇总的话，加一句代码就行。

1. Sub ykcbf()  '//2024.8.15   加上D列汇总计算
   
2.     r = Cells(Rows.Count, 3).End(3).Row
   
3.     For i = 2 To r
   
4.         m = Cells(i, 1).MergeArea.Count
   
5.         Set Rng = Cells(i, 2).Resize(m, 2)
   
6.         Rng.Sort Rng.Cells(1, 2), 2
   
7.         Cells(i, 4) = Application.Sum(Cells(i, 3).Resize(m))
   
8.         i = i + m - 1
   
9.     Next
   
10.     MsgBox "OK！"
    
11. End Sub
    

复制代码

jylai

ykcbf1100 发表于 2024-8-15 08:30
被你的效果图误导，你效果图中就没有汇总。

改一下吧。

老师是我的错，误导老师了
您太厉害了，再次感谢您得到您热心帮忙