[已解决]向下合并空单元格 最好用数组

张雄友

向下合并空单元格.

最佳答案

月排行榜 / 总排行榜

xdragon

2014-8-21 21:19

张雄友 发表于 2014-8-21 20:49
这样的话，如果选择区域是整列的话，最后的空单元也会合并了。可以防止？？？？

这个不能两全，你要默认到最后一个非空单元格结束也是很容易做的。

1. Sub 人性化选择问题()
   
2.    On Error Resume Next
   
3.    Dim arr, st&, en&, rng As Range, n&, m%, i&, j%
   
4.    Set rng = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
   
5.    If rng Is Nothing Then Exit Sub
   
6.    n = rng.Row - 1: m = rng.Column - 1
   
7.    rng.UnMerge
   
8.    arr = rng.Value
   
9.    For j = 1 To UBound(arr, 2)
   
10.         For i = 1 To UBound(arr)
    
11.             If Len(arr(i, j)) Then
    
12.               st = i - 1
    
13.               If en Then Range(Cells(en + n, j + m), Cells(st + n, j + m)).Merge
    
14.               en = i
    
15.             End If
    
16.         Next
    
17.         st = 0: en = 0
    
18.     Next
    
19. End Sub

复制代码

跳转到最佳答案楼层

易安1

xdragon

1. Sub t()
   
2.   Dim arr, st&, en&, rng As Range
   
3.   Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
   
4.   rng.UnMerge
   
5.   arr = rng.Value
   
6.   For i = 1 To UBound(arr)
   
7.       If Len(arr(i, 1)) Then
   
8.         st = i - 1
   
9.         If en Then Range(Cells(en, 1), Cells(st, 1)).Merge
   
10.         en = i
    
11.       End If
    
12.   Next
    
13. End Sub

复制代码

张雄友

xdragon 发表于 2014-8-21 20:12

您帮我看看，红字代码哪里用得对不对？ 要不要改成其它？

Sub 人性化选择问题()
  On Error Resume Next
  Dim arr, st&, en&, rng As Range
  Set rng = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
  If rng Is Nothing Then Exit Sub
  rng.UnMerge
  arr = rng.Value
  For i = 1 To UBound(arr)
      If Len(arr(i, 1)) Then
        st = i - 1
        If en Then Range(Cells(en, rng.Column), Cells(st, rng.Column)).Merge
        en = i
      End If
  Next
End Sub

张雄友

xdragon 发表于 2014-8-21 20:12

是否支持多列的？还是只支持单列的？

xdragon

张雄友 发表于 2014-8-21 20:21
您帮我看看，红字代码哪里用得对不对？ 要不要改成其它？

Sub 人性化选择问题()

你要选择区域的画，代码就没这么容易了。需要考虑不是第一行开始，还有选择的最后一个单元格有空白单元格的情况。

1. 
   
2. Sub 人性化选择问题()
   
3.    On Error Resume Next
   
4.    Dim arr, st&, en&, rng As Range, n&, m%, i&, j%
   
5.    Set rng = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
   
6.    If rng Is Nothing Then Exit Sub
   
7.    n = rng.Row - 1: m = rng.Column - 1
   
8.    rng.UnMerge
   
9.    arr = rng.Value
   
10.    For j = 1 To UBound(arr, 2)
    
11.         For i = 1 To UBound(arr)
    
12.             If Len(arr(i, j)) Then
    
13.               st = i - 1
    
14.               If en Then Range(Cells(en + n, j + m), Cells(st + n, j + m)).Merge
    
15.               en = i
    
16.             End If
    
17.         Next
    
18.         If st < en Then Range(Cells(en + n, j + m), Cells(UBound(arr) + n, j + m)).Merge
    
19.         st = 0: en = 0
    
20.     Next
    
21. End Sub

复制代码

支持多行多列。。。

张雄友

xdragon 发表于 2014-8-21 20:37
你要选择区域的画，代码就没这么容易了。需要考虑不是第一行开始，还有选择的最后一个单元格有空白单元 ...

这样的话，如果选择区域是整列的话，最后的空单元也会合并了。可以防止？？？？

xdragon

张雄友 发表于 2014-8-21 20:49
这样的话，如果选择区域是整列的话，最后的空单元也会合并了。可以防止？？？？

这个不能两全，你要默认到最后一个非空单元格结束也是很容易做的。

1. Sub 人性化选择问题()
   
2.    On Error Resume Next
   
3.    Dim arr, st&, en&, rng As Range, n&, m%, i&, j%
   
4.    Set rng = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
   
5.    If rng Is Nothing Then Exit Sub
   
6.    n = rng.Row - 1: m = rng.Column - 1
   
7.    rng.UnMerge
   
8.    arr = rng.Value
   
9.    For j = 1 To UBound(arr, 2)
   
10.         For i = 1 To UBound(arr)
    
11.             If Len(arr(i, j)) Then
    
12.               st = i - 1
    
13.               If en Then Range(Cells(en + n, j + m), Cells(st + n, j + m)).Merge
    
14.               en = i
    
15.             End If
    
16.         Next
    
17.         st = 0: en = 0
    
18.     Next
    
19. End Sub

复制代码