excel合并单元格保留所有数据

[hellohappy]

前言：
    代码和方法都是原创的，主要是方便处理数据。方法其实很简单，稍微认真看看都能懂，而且代码已经写好了，复制粘贴就可以用，我这里就先简单介绍一下这个方法，再详细介绍。事实上你可以任意方法合并你的数据，如果会一点VBA或者VBS程序的话。
    如果我有新的想法或者代码会在后面帖子继续讲。

方法概要：

    要合并你选中的单元格区域，并保留所有单元格里的文本？你可以在你的表中VBA工程里插入一模块，复制以下宏代码，然后设置快捷键既可以快速应用这个方法。合并以后，合并的单元格直接为换行显示的代码如下：

代码： 全选

Sub 合并()
Dim ran As Range
Dim str As String
For Each ran In Selection
str = str & ran & vbCrLf
Next
str = Left(str, Len(str) - 1)
Selection.ClearContents
Selection.Merge
Selection = str
End Sub

    如果希望不换行，也就是所有单元格合在一块,使用这个代码：

代码： 全选

 Sub 合并2()
Dim ran As Range
Dim str As String
For Each ran In Selection
str = str & ran
Next
str = Left(str, Len(str))
Selection.ClearContents
Selection.Merge
Selection = str
End Sub

方法详细介绍：

    首先要知道怎么插入excel中VBA工程里的模块。
        以excel 2016年版本为例，快捷键 ALT + F11 可以快速打开 VB窗口。当然，excel也可以在这里点开：

    点开后的长这样，只要在上面粘贴代码，然后关掉：

    关掉VB窗口，用快捷Alt+F8打开宏，或者在excel的这里点开：

    在选项最下方找到“合并”这个宏：
        只要你写了都能找到，几个选项里面，通常在最后一行

excel合并单元格保留所有数据3.png (46.58 KiB) 查看 22353 次

excel合并单元格保留所有数据3.png (46.58 KiB) 查看 22353 次

    设置快捷键（完成）：

excel合并单元格保留所有数据4.png (60.17 KiB) 查看 22353 次

excel合并单元格保留所有数据4.png (60.17 KiB) 查看 22353 次

    效果展示：

效果对比

显示

        这是普通合并：

excel合并单元格保留所有数据5.png (36.07 KiB) 查看 22353 次

excel合并单元格保留所有数据5.png (36.07 KiB) 查看 22353 次

        这是使用上面的方法合并：

excel合并单元格保留所有数据6.png (7.6 KiB) 查看 22353 次

excel合并单元格保留所有数据6.png (7.6 KiB) 查看 22353 次

        这是上面的方法，但是删掉了“ & vbCrLf”，也就是不换行的效果。

excel合并单元格保留所有数据7.png (7.26 KiB) 查看 22353 次

excel合并单元格保留所有数据7.png (7.26 KiB) 查看 22353 次

赞赏

×hellohappy

谢谢老板~

2元5元10元50元100元任意金额

2元

使用微信扫描二维码完成支付

[hellohappy]

前面介绍的方法还可以延伸很多不同的vba代码，比如，原始数据是这样的：

上下单元格合并1.png (12.52 KiB) 查看 22346 次

上下单元格合并1.png (12.52 KiB) 查看 22346 次

我使用上一贴的方法，粘贴下面的代码，然后选中这些单元格，按本人设定的快捷键：

上下单元格合并2.png (18.32 KiB) 查看 22346 次

上下单元格合并2.png (18.32 KiB) 查看 22346 次

不同代码的效果如下：

    上下单元格合并 & 不换行不加空格：

隐藏内容

显示

代码： 全选

Sub 上下合并不换行()
    Dim ran As Range
    Dim str As String
    Dim i, j As Long
    Dim numcol, numraw As Long
    Dim countcol, countraw As Long
    countraw = Selection.Rows.Count
    countcol = Selection.Columns.Count
    numraw = Selection.Row
    numcol = Selection.Column
    For i = 1 To countcol
        str = ""
        For j = 1 To countraw
            str = str & Cells(numraw + j - 1, numcol + i - 1)
        Next j
        str = Left(str, Len(str))
        Set ran = Range(Cells(numraw, numcol + i - 1), Cells(numraw + countraw - 1, numcol + i - 1))
        ran.ClearContents
        ran.Merge
        ran = str
    Next i
End Sub

上下单元格合并3.png (8.74 KiB) 查看 22346 次

上下单元格合并3.png (8.74 KiB) 查看 22346 次

    上下单元格合并 & 不换行加空格：

隐藏内容

显示

代码： 全选

Sub 上下合并不换行加空格()
    Dim ran As Range
    Dim str As String
    Dim i, j As Long
    Dim numcol, numraw As Long
    Dim countcol, countraw As Long
    countraw = Selection.Rows.Count
    countcol = Selection.Columns.Count
    numraw = Selection.Row
    numcol = Selection.Column
    
    For i = 1 To countcol
        str = ""
        For j = 1 To countraw
            If Cells(numraw + j - 1, numcol + i - 1) <> "" Then
                str = str & Cells(numraw + j - 1, numcol + i - 1) & " "
            End If
        Next j
        If str <> "" Then
            str = Left(str, Len(str) - 1)
        End If
        Set ran = Range(Cells(numraw, numcol + i - 1), Cells(numraw + countraw - 1, numcol + i - 1))
        ran.ClearContents
        ran.Merge
        ran = str
    Next i
End Sub

上下单元格合并4.png (9.47 KiB) 查看 22346 次

上下单元格合并4.png (9.47 KiB) 查看 22346 次

    上下单元格合并 & 换行不加空格：

隐藏内容

显示

代码： 全选

 Sub 上下合并换行()
    Dim ran As Range
    Dim str As String
    Dim i, j As Long
    Dim numcol, numraw As Long
    Dim countcol, countraw As Long
    countraw = Selection.Rows.Count
    countcol = Selection.Columns.Count
    numraw = Selection.Row
    numcol = Selection.Column
    
    For i = 1 To countcol
        str = ""
        For j = 1 To countraw
            str = str & Cells(numraw + j - 1, numcol + i - 1) & vbCrLf
        Next j
        str = Left(str, Len(str) - 1)
        Set ran = Range(Cells(numraw, numcol + i - 1), Cells(numraw + countraw - 1, numcol + i - 1))
        ran.ClearContents
        ran.Merge
        ran = str
    Next i
End Sub

上下单元格合并5.png (9.57 KiB) 查看 22346 次

上下单元格合并5.png (9.57 KiB) 查看 22346 次

    为了方便大家使用和修改，我再提供一个 左右合并，加空格不换行 的例子

隐藏内容

显示

代码： 全选

 Sub 左右合并不换行加空格()
    Dim ran As Range
    Dim str As String
    Dim i, j As Long
    Dim numcol, numraw As Long
    Dim countcol, countraw As Long
    countraw = Selection.Rows.Count
    countcol = Selection.Columns.Count
    numraw = Selection.Row
    numcol = Selection.Column
    
    For i = 1 To countraw
        str = ""
        For j = 1 To countcol
            str = str & Cells(numraw + i - 1, numcol + j - 1) & " "
        Next j
        str = Left(str, Len(str) - 1)
        Set ran = Range(Cells(numraw + i - 1, numcol), Cells(numraw + i - 1, numcol + countcol - 1))
        ran.ClearContents
        ran.Merge
        ran = str
    Next i
End Sub

左右单元格合并1.png (11.89 KiB) 查看 22341 次

左右单元格合并1.png (11.89 KiB) 查看 22341 次