在 Excel 中合并单元格而不丢失数据

Posted 2023-02-23

【中文标题】在 Excel 中合并单元格而不丢失数据

【英文标题】：Merging cells in Excel without loosing data

【发布时间】：2013-09-18 01:23:23

【问题描述】：

首先很抱歉为此创建了一个新线程，但我无法在现有线程中发表评论。

我正在尝试像this 线程一样合并很多单元格，但我对编码有点陌生，尤其是 excel/VBA，所以我不能让它工作。我有同样的场景（除了我没有任何空行）所以我只是尝试在现有线程中使用代码，但并不真正理解语法：

Sub mergecolumn()

Dim cnt As Integer
Dim rng As Range
Dim str As String

For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
cnt = Cells(i, 1).MergeArea.Count
Set rng = Range(Cells(i, 2), Cells(i - cnt + 1, 2))

For Each cl In rng
    If Not IsEmpty(cl) Then str = str + vbNewLine + cl
Next
If str <> "" Then str = Right(str, Len(str) - 2)

Application.DisplayAlerts = False
rng.Merge
rng = str
Application.DisplayAlerts = True

str = ""
i = i - cnt + 1
Next i

End Sub

我尝试以不同的方式运行宏，标记多列、标记多行和仅标记某些区域，但我总是得到：

运行时错误“13”： 类型不匹配

当我进入调试屏幕时，这会被标记：

str = str + vbNewLine + cl

我通过 Developer-ribbon->Visual Basic->Insert->Module 添加了宏，然后将代码粘贴到那里并保存。

提前感谢您的帮助 //乔金

【问题讨论】：

我很久以前创建了一个插件，它完全可以满足您的需求。让我看看我能不能得到代码。

那太棒了！

【参考方案1】：

这里有两个版本的代码。

VER 1（不忽略空白单元格）

'~~> For Group MERGING (Merge Cells and Keep All text)
Public Sub Sample()
    On Error GoTo ErrMergeAll

    Application.DisplayAlerts = False

    Dim Cl As Range
    Dim strTemp As String

    '~~> Collect values from all the cells and separate them with spaces
    For Each Cl In Selection
        If Len(Trim(strTemp)) = 0 Then
            strTemp = strTemp & Cl.Value
        Else
            strTemp = strTemp & vbNewLine & Cl.Value
        End If
    Next

    strTemp = Trim(strTemp)

    '~~> Merging of cells
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = False
    End With
    Selection.Merge

    '~~> Set new value of the range
    Selection.Value = strTemp

    Application.DisplayAlerts = True
    Exit Sub

ErrMergeAll:
    MsgBox Err.Description, vbInformation
    Application.DisplayAlerts = True
End Sub

VER 2（忽略空白单元格）

'~~> For Group MERGING (Merge Cells and Keep All text)
Public Sub Sample()
    On Error GoTo ErrMergeAll

    Application.DisplayAlerts = False

    Dim Cl As Range
    Dim strTemp As String

    '~~> Collect values from all the cells and separate them with spaces
    For Each Cl In Selection
        If Len(Trim(Cl.Value)) <> 0 Then
            If Len(Trim(strTemp)) = 0 Then
                strTemp = strTemp & Cl.Value
            Else
                strTemp = strTemp & vbNewLine & Cl.Value
            End If
        End If
    Next

    strTemp = Trim(strTemp)

    '~~> Merging of cells
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = False
    End With
    Selection.Merge

    '~~> Set new value of the range
    Selection.Value = strTemp

    Application.DisplayAlerts = True
    Exit Sub

ErrMergeAll:
    MsgBox Err.Description, vbInformation
    Application.DisplayAlerts = True
End Sub

屏幕截图

【讨论】：

这看起来完全符合我的需要。现在我只需要弄清楚如何在 excel 中创建加载项。 =)

会THIS 帮忙吗？ :)

看起来确实如此。非常感谢！你就是那个男人。 :D