逐行合并单元格而不丢失任何数据开发者社区

link之家

链接快照平台

输入网页链接，自动生成快照
标签化管理网页链接

文章/答案/技术大牛

发布

Sub JoinAndMerge()
'joins all the content in selected cells
'and puts the resulting text in top most cell
'then merges all cells
Dim outputText As String
Const delim = " "
On Error Resume Next
For Each cell In Selection
outputText = outputText & cell.value & delim
Next cell
With Selection
.Clear
.Cells(1).value = outputText
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
End With
End Sub

Sub JoinAndMerge2()
'joins all the content in selected cells
'and puts the resulting text in top most cell
'then merges all cells
Dim outputText As String
Const delim = " "
On Error Resume Next
Dim cell_value As Variant
Dim counter As Integer
Dim xlastRow As Long
Dim xlastColumn As Long
xlastRow = Worksheets("Sheet48").UsedRange.Rows.Count
xlastColumn = Worksheets("Sheet48").UsedRange.Columns.Count
'Looping through A column define max value
For i = 1 To xlastRow
    'Row counter
    counter = 1
    'Take cell one at the time
    cell_value = ThisWorkbook.ActiveSheet.Cells(1, i).value
    For Each cell In Selection
    outputText = outputText & cell.value & delim
    Next cell
        With Selection
        .Clear
        .Cells(1).value = outputText
        .Merge
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    counter = counter + 1
Next i
End Sub

Option Explicit
Sub Merger()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim MyCell As Range, Merged As String, i, iArr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each MyCell In ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
    For i = 1 To ws.Cells(MyCell.Row, ws.Columns.Count).End(xlToLeft).Column
        Merged = Merged & Chr(32) & MyCell.Offset(, i - 1) 'Build String
    Next i
        MyCell.Resize(1, i - 1).Merge 'Merge
        MyCell = Right(Merged, Len(Merged) - 1) 'Insert String
        Merged = "" 'Reset string for next loop
        MyCell.HorizontalAlignment = xlGeneral
        MyCell.VerticalAlignment = xlCenter
        MyCell.WrapText = True
Next MyCell
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

For (Columns, 2, LastColumn, Step 2)
   For(Rows, 3, LastRow)
      With Worksheet
         If .Cells(Row,Column) <> vbNullString then
            .cells(Row,Column-1)=.cells(Row,Column-1).Value2 _
                & StringDeliminator & .cells(Row,Column).Value2
         End If
      End with

问 逐行合并单元格而不丢失任何数据 EN

回答 2

Stack Overflow用户

Stack Overflow用户