合并每一行中的单元格

我知道如何合并单元格，我知道如何合并列，我知道如何合并表格。 然而，有什么办法，我可以合并所有单元格连续行数众多？ 所以为了进一步澄清，我的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行都有一个单元格。 我已经能够find一个方法来做到这一行，但如果我扩大我的范围它合并到一个单元格而不是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。

Answer 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 

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

Answer 2

嗨，这里简单的代码2方式。 我testing了两个范围A2：C3（第一，中间，姓氏）和A11：C13上的某个date改为你的

 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 

Answer 3

使用鼠标select要处理脚本的部分后，可以使用以下脚本得到相同的结果：

  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