关于合并单元格的操作以及保留所有数据并实现单元格合并

lb_bn

1, 设表中A1:B2区域已合并,则有如下位移操作区别:

1. Sub bbb()                                       '对合并区域的位移操作
   
2.     MsgBox Range("a1")(2, 2).Address            '显示b2地址
   
3.     MsgBox Range("a1").Offset(1, 1).Address     '显示c3地址,但当a1非合并单元格,则显示b2地址
   
4. End Sub

复制代码

2, 合并一列中连续相同的单元格并保留单元格中的数据:

当然, 这个目的可以用手动操作实现, 论坛里有方法, 此帖不再叙述.
下面贴出用VBa实现的方法（核心思想为拷贝格式：PasteSpecial xlPasteFormats）

代码1:

1. Sub bbb1()                                      '适用于单列区域
   
2.     With [e3:e19]
   
3.         .Offset(0, 1).EntireColumn.Insert
   
4.         For i = 1 To .Count - 1
   
5.             If .Cells(i) = .Cells(i + 1) Then .Cells(i).Offset(0, 1).Resize(2, 1).Merge
   
6.         Next
   
7.         .Offset(0, 1).Copy
   
8.         .PasteSpecial xlPasteFormats
   
9.         .Offset(0, 1).EntireColumn.Delete
   
10.     End With
    
11. End Sub

复制代码

代码2:

1. Sub bbb3()                                      '高速合并
   
2.     Dim i%, y%, arr1(), arr2()
   
3.     With [e3:e19]
   
4.         On Error Resume Next
   
5.         Application.DisplayAlerts = False
   
6.         arr1 = [e3:e19].Value
   
7.         ReDim arr2(1 To UBound(arr1), 1 To 1)
   
8.         For i = 1 To UBound(arr1) - 1
   
9.             If arr1(i, 1) = arr1(i + 1, 1) Then
   
10.                 If y Mod 2 = 0 Then
    
11.                     arr2(i, 1) = 1: arr2(i + 1, 1) = 1
    
12.                 Else
    
13.                     arr2(i, 1) = "#N/A": arr2(i + 1, 1) = "#N/A"
    
14.                 End If
    
15.             Else
    
16.                 y = y + 1
    
17.             End If
    
18.         Next
    
19.         .Offset(0, 1).EntireColumn.Insert
    
20.         .Offset(0, 1).Value = arr2
    
21.         .Offset(0, 1).SpecialCells(2, 1).Merge
    
22.         .Offset(0, 1).SpecialCells(2, 16).Merge
    
23.         .Offset(0, 1).Copy
    
24.         .PasteSpecial xlPasteFormats
    
25.         .Offset(0, 1).EntireColumn.Delete
    
26.         Application.DisplayAlerts = True
    
27.         If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
    
28.     End With
    
29. End Sub

复制代码

3, 操作用附件:
合并单元格并保留数据.zip (11.41 KB, 下载次数: 832)

2009-12-22 17:30 上传

点击文件名下载附件

[ 本帖最后由 lb_bn 于 2009-12-22 18:08 编辑 ]

lb_bn

核心是通过  PasteSpecial xlPasteFormats 来实现。
拷贝格式。

ccwan

多谢分享。

3x3eyes

这是咱们用格式刷制造合并单元格并保留值的vba版吧？？

lb_bn

自动化嘛。

飞云楼主

谢谢分享。

zz5151353

收藏學習,謝謝樓主提供分享 !!!

yjwly

请教，如果需要多列一起执行，怎么修改代码呢？

如：Sub bbb3()                                      '高速合并
    Dim i%, y%, arr1(), arr2()
    With [e3:e19]
        On Error Resume Next
        Application.DisplayAlerts = False
        arr1 = [e3:e19].Value
现在只对e3:e19有效，我想对E列到H列都这样执行，怎么修改？

lhx120824

进来学习。

menboy

太好了，我收藏了。