合并单元格有没有更加好的方法，数据量大时反应太慢，会卡住

dnvjfdeuff

合并单元格有没有更加好的方法，数据量大时反应太慢，会卡住

ynzsvt

遇到不等时首尾合并。

dragonthree

是这样合并的呀

dragonthree

1. Private Sub CommandButton1_Click()
   
2. Dim irow As Integer
   
3. Dim i As Integer
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Set d = CreateObject("scripting.dictionary")
   
7. With ActiveSheet
   
8.   arr = .Range("a1:b" & .Cells(.Rows.Count, 1).End(3).Row)
   
9. End With
   
10. ReDim brr(1 To UBound(arr), 1 To 4)
    
11. For i = 1 To UBound(arr)
    
12.    d(arr(i, 1)) = d(arr(i, 1)) + 1
    
13. Next
    
14. 
    
15. For i = 2 To UBound(arr)
    
16.     If d.exists(Range("A" & i).Value) Then
    
17.         x = d(Range("A" & i).Value)
    
18.         Range(Range("a" & i), Range("a" & i + x - 1)).Merge '单元格合并
    
19.         i = i + x - 1
    
20.     End If
    
21. Next
    
22. Application.ScreenUpdating = False
    
23. Application.DisplayAlerts = True
    
24. End Sub

复制代码

相同的编码是不是在一起？如果是在一起，可以先用字典计个数，然后一次性合并，就不需要STEP 1了，比如有8个14030101，就8行合并，再i=i+8(也可能是i=i+7），你试下就知道了

dragonthree

Private Sub CommandButton1_Click()
Dim irow As Integer
Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
  arr = .Range("a1:b" & .Cells(.Rows.Count, 1).End(3).Row)
End With
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 1 To UBound(arr)
   d(arr(i, 1)) = d(arr(i, 1)) + 1
Next

For i = 2 To UBound(arr)
    If d.exists(Range("A" & i).Value) Then
        x = d(Range("A" & i).Value)
        Range(Range("a" & i), Range("a" & i + x - 1)).Merge '单元格合并
        i = i + x - 1
    End If
Next
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub

木槿花西月锦绣

楼主把合并单元格那行代码放进if判断里，少执行几次应该会快不少吧
Private Sub CommandButton1_Click()
Dim irow As Integer
Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
irow = Range("b" & Rows.Count).End(xlUp).Row
m = irow
For i = irow To 2 Step -1
    If Range("A" & i).Value = Range("a" & i - 1).Value Then
        n = i - 1 '单元格合并
        Else
        Range(Range("a" & n), Range("a" & m)).Merge '单元格合并
        m = n - 1
    End If
Next i
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub

liuyu5863016

1. Function 编码计数(rngs As Range)
   
2. 
   
3.     Dim d As Object
   
4.     Dim rng As Range
   
5.    
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.    
   
8.     ' 添加键
   
9.     For Each rng In rngs
   
10.         d.Item(rng.Value) = 0
    
11.         Debug.Print d.Item(rng.Value)
    
12.     Next rng
    
13.    
    
14.     ' 对键计数
    
15.     For Each rng In rngs
    
16.         d.Item(rng.Value) = d.Item(rng.Value) + 1
    
17.         Debug.Print d.Item(rng.Value)
    
18.     Next rng
    
19.    
    
20.     ' 返回函数
    
21.     Set 编码计数 = d
    
22.    
    
23. End Function
    
24. 
    
25. 
    
26. Sub t()
    
27.    
    
28.     Application.DisplayAlerts = False
    
29.    
    
30.     Dim rng As Range
    
31.     Dim d As Object
    
32.    
    
33.     Set rng = Range("a2:a817")
    
34.    
    
35.     Set d = 编码计数(rng)
    
36.    
    
37.     ' 合并单元格
    
38.     Dim i%, j%
    
39.     For i = 2 To rng.Rows.Count
    
40.         j = d.Item(Cells(i, "A").Value)
    
41.         Range("A" & i & ":A" & i + j - 1).Merge
    
42.         i = i + j - 1
    
43.     Next i
    
44.    
    
45.     Application.DisplayAlerts = True
    
46. End Sub

复制代码

zpy2

select count(*) 行,编码,group_concat(序号) from Sheet1 group by 编码;

dnvjfdeuff

非常大神们

ykcbf1100

分区块操作，用数组记录各区块的首行和尾行，然后区块合并，速度快很多，我这里2万行数据，合并用时0.38秒。

附件供参考。。。