合并每一行的单元格答案

【问题标题】：Merge cells in each row合并每一行的单元格
【发布时间】：2015-11-19 00:47:32
【问题描述】：

我知道如何合并单元格，我知道如何合并列，我知道如何合并表格。但是，有什么方法可以将所有单元格合并到多行中？因此，为了进一步澄清，我的 Excel 工作表中有三行如下：

First Name    Middle Name    Last Name
John          James          Smith
Sally         Anne           Lavery
Tom           John           Doe

我需要能够合并每一行中的这些单元格，如下所示：

Name
John; James; Smith
Sally; Anne; Lavery
Tom; John; Doe

所以 3 行都有一个单元格。我已经能够找到一种方法来为 1 行执行此操作，但如果我扩展我的范围，它会将它们全部合并到一个单元格中，而不是 3 行：

Dim Rng As Range
Dim WorkRng As Range
Dim Sigh As String
On Error Resume Next
Set WorkRng = Application.Selection
Set WorkRng = Range("A18:I19")
Sigh = ";"
xOut = ""
Application.DisplayAlerts = False
For Each Rng In WorkRng
    xOut = xOut & Rng.Value & Sigh
Next
With WorkRng
    .Merge
    .Value = VBA.Left(xOut, VBA.Len(xOut) - 1)
End With
Application.DisplayAlerts = True

我正在使用 Excel 2010。

【问题讨论】：

标签： vba excel merge

【解决方案1】：

您需要逐行处理您选择的范围：

Sub Test1()

    MergeRowByRow Range("A18:I19")

    'or if you want a different delimiter:
    MergeRowByRow Range("A18:I19"), "|"

End Sub

Sub MergeRowByRow(SourceRange As Range, Optional Sigh As String = ";")

    Dim rRow As Range
    Dim rCell As Range
    Dim xOut As String

    For Each rRow In SourceRange.Rows
        xOut = ""
        For Each rCell In rRow.Cells
            If rCell.Value <> "" Then
                xOut = xOut & rCell.Value & Sigh
            End If
        Next rCell
        Application.DisplayAlerts = False
        rRow.Merge
        Application.DisplayAlerts = True
        If Len(rRow.Cells(1).Value) > 0 Then
            rRow.Cells(1).Value = Left(xOut, Len(xOut) - 1)
        End If
    Next rRow

End Sub

我已更新，因此空白单元格不会导致两个连续的分隔符，如果最终结果是空白单元格，则在删除最后一个分隔符时不会出错。

【讨论】：

这正是我正在寻找的，但是有一个问题，有些行在“中间名”列中没有任何信息。有了这个查询，它仍然放在 ; 中，所以它看起来像 John;;Doe。有没有办法阻止这种情况发生？
我已更新以考虑双定界符 - 如果这导致一个空单元格，它在尝试删除最后一个字符时不会崩溃。
完美，这正是我所需要的。感谢您的所有帮助

【解决方案2】：

您好，这里有 2 种方式的简单代码。我测试了两个范围 A2:C3（名字、中间名、姓氏）和 A11:C13 上的某个日期将其更改为您的

Sub CompactNameIntoOneCell()
Dim str As String
str = "name" & vbCrLf

    For i = 2 To 4
        For Each cell In Range("A" & i, "C" & i)
            str = str & cell & ","
        Next cell
        str = str & vbCrLf
    Next i
' if you want only one cell
Range("A2", "C4").ClearContents
Range("A2").Select
Selection.Value = str

'if you want merce the range into one cell
Range("A11", "C13").ClearContents
Range("A11").Select
Selection.Value = str
Range("A11:C13").Select

    Selection.Merge
    With Selection   'format to your like
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
End Sub

【讨论】：

【解决方案3】：

在您用鼠标选择要处理脚本的部分后，使用以下脚本可以获得相同的结果：

    sub Merge_Text()
        for each c in Selection
            if c.Value <> "" then c.Value = c.Value & "; " & c.Offset(0,1).Value & "; " & c.Offset(0,2).Value
            c.Offset(0,1).Value = ""
            c.Offset(0,2).Value = ""
        next
    end sub

【讨论】：