求助合并单元格下面加汇总代码

ykcbf1100

懒猫爱哭 发表于 2025-3-19 17:28
ykcbf1100大师 ，这里还是不理解，zrr(k) = Array(i, i)，这里指的是第K个区块的尾部赋值是吗？就是后面 ...

zrr(k) = Array(i, i)是初值，必须要有。zrr(k)(1)是区块的尾行。

ykcbf1100

aosiner123 发表于 2025-3-19 18:14
插入小计 是不是限制一下，现在可以多次插入 一直累计

你一直插入干啥呢，用删除小计删除一下，重来一次就行了。这个可以吃后悔药的。

ykcbf1100

aosiner123 发表于 2025-3-19 18:14
插入小计 是不是限制一下，现在可以多次插入 一直累计

改好了。。。

shiruiqiang

ykcbf1100 发表于 2025-3-19 18:16
这个有好几个方法的，有时，我感觉数组更简单。
用字典的话，各个区块的关键字不能重复的，用数组就可以 ...

这种写法就是必须先排序一下。否则区块太多，散乱

ykcbf1100

shiruiqiang 发表于 2025-3-19 18:46
这种写法就是必须先排序一下。否则区块太多，散乱

那是的。。。

翁知江安

Sub test()
Dim i, j, k, m, n, s, t As Integer
Dim ar, cr As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ar = Sheet1.[a6].CurrentRegion
For i = 2 To UBound(ar)
      If ar(i, 1) = "" Then
       ar(i, 1) = ar(i - 1, 1)
       End If
Next
ReDim cr(1 To 500, 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
    If i = 2 Then
    m = m + 1
      For j = 1 To UBound(ar, 2)
      cr(m, j) = ar(i, j)
      Next
      d(cr(1, 1)) = d(cr(1, 1)) + 1
    End If
    If i >= 3 Then
       m = m + 1
     If ar(i, 1) = ar(i - 1, 1) Then
        For j = 1 To UBound(ar, 2)
        cr(m, j) = ar(i, j)
        Next
        d(cr(m, 1)) = d(cr(m, 1)) + 1
      Else
      cr(m, 1) = "汇总"
        m = m + 1
       For j = 1 To UBound(ar, 2)
        cr(m, j) = ar(i, j)
        Next
        d(cr(m, 1)) = d(cr(m, 1)) + 1
       End If
      End If
Next
m = m + 1
cr(m, 1) = "汇总"
Sheet1.[f1].Resize(500, UBound(ar, 2)).ClearContents
Sheet1.[f1].Resize(500, UBound(ar, 2)).ClearFormats
Sheet1.[f1].Resize(m, UBound(ar, 2)) = cr
n = 1
For k = 1 To 1000
s = d(cr(n, 1))
Sheet1.Cells(n + s, 8) = WorksheetFunction.Sum(Sheet1.Cells(n, 8).Resize(s, 1))
Sheet1.Cells(n + s, 9) = WorksheetFunction.Sum(Sheet1.Cells(n, 9).Resize(s, 1))
Sheet1.Cells(n, 6).Resize(s, 1).Merge
n = n + 1 + s
If n > m Then
Exit For
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

lyfegf

用轮子很快

1. Dim f As New clsFunc
   
2. Sub Main()
   
3.     Dim i&, r, j&, y&, n&, m&, x, arr, brr, arrjg
   
4.     arr = f.GetArrData([a6], 1, 1, , mCols:=4)
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
7.     Next
   
8.    
   
9.     Dim d As New clsDic, rng As Range
   
10.     Dim cjg As New Collection, cRow As Collection
    
11.     d.init_Collection arr, "1", 1, , True
    
12.     For Each x In d.Keys
    
13.         Set cRow = d.Rows_Collection(x & "", xxCollection)
    
14.         cjg.Add f.myFilter(arr, cRow)
    
15.         
    
16.         ReDim brr(1 To 1, 1 To UBound(arr, 2))
    
17.         brr(1, 1) = "汇总"
    
18.         brr(1, 3) = d.Sum_collection(x & "", 3)
    
19.         brr(1, 4) = d.Sum_collection(x & "", 4)
    
20.         cjg.Add brr  '添加汇总行
    
21.     Next
    
22.     arrjg = f.Coll2dToArr(cjg)
    
23.     Set rng = f.Get_range_data([f7], , USEDRANGEROW, , usedRangeColumn)
    
24.     If Not rng Is Nothing Then
    
25.         rng.UnMerge
    
26.         rng.ClearContents
    
27.     End If
    
28.     f.Auto_ArrToRange arrjg, [f7]
    
29.     批量合并单元格 "F", 7
    
30. End Sub
    
31. Sub 批量合并单元格(lie, sr)
    
32.     Dim i&, r&, y&, k&, n&, m&, arr
    
33.     Dim er&, ssR$, col&, Sh As Worksheet
    
34.     With Application
    
35.         .ScreenUpdating = False
    
36.         .DisplayAlerts = False
    
37.         .AskToUpdateLinks = False
    
38.     End With
    
39.      'Set sh = Sheet1 '这里也要改
    
40.     'lie = "b": col = 2 '合并那列就改这2个地方
    
41.    
    
42.     Set Sh = ActiveSheet
    
43.    
    
44.     If VBA.IsNumeric(lie) Then
    
45.         col = lie
    
46.         lie = Split(Cells(1, col).Address, "$")(1)
    
47.     Else
    
48.         col = Range(lie & 1).column
    
49.     End If
    
50.     On Error Resume Next
    
51.     Sh.ShowAllData
    
52.     On Error GoTo 0
    
53.    
    
54.     r = Sh.Cells(Sh.Rows.Count, lie).End(xlUp).Row
    
55.     arr = Sh.Range("a1").Resize(r + 1, col).Value '加一行，为了循环的时候比较
    
56.     'sr = 2  '开始合并的行数
    
57.     For i = sr To r
    
58.         If arr(i, col) <> arr(i + 1, col) Then
    
59.             ssR = ssR & "," & lie & sr & ":" & lie & i
    
60.             sr = i + 1
    
61.         End If
    
62.         If Len(ssR) > 200 Then
    
63.            Sh.Range(Mid(ssR, 2)).Merge
    
64.             ssR = ""
    
65.         End If
    
66.         If ssR <> "" And i = r Then
    
67.            Sh.Range(Mid(ssR, 2)).Merge
    
68.         End If
    
69.     Next
    
70.     With Application
    
71.         .ScreenUpdating = True
    
72.         .DisplayAlerts = True
    
73.         .AskToUpdateLinks = True
    
74.     End With
    
75. End Sub
    

复制代码

aosiner123

ykcbf1100 发表于 2025-3-19 18:22
改好了。。。

这个是否可以改成 每个小计名称 上面都根据A列的合并单元格名字合并命名呢，例如 上海中心小计   安徽中心小计   以此类推，谢谢

ykcbf1100

aosiner123 发表于 2025-4-9 19:05
这个是否可以改成 每个小计名称 上面都根据A列的合并单元格名字合并命名呢，例如 上海中心小计   安徽中 ...

小改一下即可。