[原创]excel合并单元格保留所有数据

这里只有作者精心编写的学习经历!
回复
头像
hellohappy
网站管理员
网站管理员
帖子: 282
注册时间: 2018年11月18日, 14:27
Been thanked: 3 time

#1 [原创]excel合并单元格保留所有数据

未读文章 hellohappy » 2019年6月06日, 21:56

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

方法概要:

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

Code: 全选

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
    如果希望不换行,也就是所有单元格合在一块,使用这个代码:

Code: 全选

 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也可以在这里点开:
excel合并单元格保留所有数据1.png

    点开后的长这样,只要在上面粘贴代码,然后关掉:
excel合并单元格保留所有数据0.png

    关掉VB窗口,用快捷Alt+F8打开宏,或者在excel的这里点开:
excel合并单元格保留所有数据2.png

    在选项最下方找到“合并”这个宏:
        只要你写了都能找到,几个选项里面,通常在最后一行
excel合并单元格保留所有数据3.png
excel合并单元格保留所有数据3.png (46.58 KiB) 查看 496 次
excel合并单元格保留所有数据3.png
excel合并单元格保留所有数据3.png (46.58 KiB) 查看 496 次

    设置快捷键(完成):
excel合并单元格保留所有数据4.png
excel合并单元格保留所有数据4.png (60.17 KiB) 查看 496 次
excel合并单元格保留所有数据4.png
excel合并单元格保留所有数据4.png (60.17 KiB) 查看 496 次

    效果展示:
效果对比
Show
        这是普通合并:
excel合并单元格保留所有数据5.png
excel合并单元格保留所有数据5.png (36.07 KiB) 查看 496 次
excel合并单元格保留所有数据5.png
excel合并单元格保留所有数据5.png (36.07 KiB) 查看 496 次

        这是使用上面的方法合并:
excel合并单元格保留所有数据6.png
excel合并单元格保留所有数据6.png (7.6 KiB) 查看 496 次
excel合并单元格保留所有数据6.png
excel合并单元格保留所有数据6.png (7.6 KiB) 查看 496 次

        这是上面的方法,但是删掉了“ & vbCrLf”,也就是不换行的效果。
excel合并单元格保留所有数据7.png
excel合并单元格保留所有数据7.png (7.26 KiB) 查看 496 次
excel合并单元格保留所有数据7.png
excel合并单元格保留所有数据7.png (7.26 KiB) 查看 496 次
hellohappy

谢谢老板~

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


Link:
Hide post links
Show post links

头像
hellohappy
网站管理员
网站管理员
帖子: 282
注册时间: 2018年11月18日, 14:27
Been thanked: 3 time

#2 [原创]上下单元格合并

未读文章 hellohappy » 2019年6月07日, 15:00

前面介绍的方法还可以延伸很多不同的vba代码,比如,原始数据是这样的:
上下单元格合并1.png
上下单元格合并1.png (12.52 KiB) 查看 489 次
上下单元格合并1.png
上下单元格合并1.png (12.52 KiB) 查看 489 次

我使用上一贴的方法,粘贴下面的代码,然后选中这些单元格,按本人设定的快捷键:
上下单元格合并2.png
上下单元格合并2.png (18.32 KiB) 查看 489 次
上下单元格合并2.png
上下单元格合并2.png (18.32 KiB) 查看 489 次

不同代码的效果如下:

    上下单元格合并 & 不换行不加空格:
Spoiler
Show

Code: 全选

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
上下单元格合并3.png (8.74 KiB) 查看 489 次
上下单元格合并3.png
上下单元格合并3.png (8.74 KiB) 查看 489 次
    上下单元格合并 & 不换行加空格:
Spoiler
Show

Code: 全选

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
上下单元格合并4.png (9.47 KiB) 查看 489 次
上下单元格合并4.png
上下单元格合并4.png (9.47 KiB) 查看 489 次
    上下单元格合并 & 换行不加空格:
Spoiler
Show

Code: 全选

 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
上下单元格合并5.png (9.57 KiB) 查看 489 次
上下单元格合并5.png
上下单元格合并5.png (9.57 KiB) 查看 489 次
    为了方便大家使用和修改,我再提供一个 左右合并,加空格不换行 的例子
Spoiler
Show

Code: 全选

 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
左右单元格合并1.png (11.89 KiB) 查看 484 次
左右单元格合并1.png
左右单元格合并1.png (11.89 KiB) 查看 484 次

Link:
Hide post links
Show post links


回复