我有一列，其中的分段被拆分在不同的行中，并且需要将段落连接到段落的第一行上的单个段落中。
我想要这个：
Column1 | Column2
The weather is | The weather is good today, how are you?
good today, how |
are you? |
|
I'm fine, | I'm fine, thank you.
thank you. |
|
|
|
There were | There were 3 empty rows in Column 1 just before this paragraph. And should have 4 rows using after the macro.
3 empty rows in |
Column1 just |
before this |
paragraph. And |
should have 4 |
rows after |
using the macro. |
|
|
More text. | More text.
我尝试过多种宏，如
https://www.extendoffice.com/documents/excel/3574-excel-concatenate-until-blank.html和https://www.mrexcel.com/board/threads/concatenate-cells-in-a-column-until-blank-cell.607461/post-4531030
但他们返回的结果是没有将其与原始行对齐。(下面是第一个宏，他们在每段后面删除了一个空白行，而完全忽略了连续的空白行(。
Column1 | Column2
The weather is | The weather is good today, how are you?
good today, how | I'm fine, thank you.
are you? |
|
I'm fine, | There were 3 empty rows in Column 1 just before this paragraph. And should have 4 rows using after the macro.
thank you. |
| More text.
|
|
There were |
3 empty rows in |
Column1 just |
before this |
paragraph. And |
should have 4 |
rows after |
using the macro. |
|
|
More text. |
有没有一种方法可以将字符串连接到一个空白单元格，然后返回断开段落第一行单元格的输出？
段落
- 调整常量部分中的值
Option Explicit
Sub Paragraphing()
' Define constants.
Const sName As String = "Sheet1"
Const sFirst As String = "A2"
Const dName As String = "Sheet1"
Const dFirst As String = "B2"
Const dDelim As String = " "
' Create a reference to the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the first cell of the Destination Column Range.
Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
' Create a reference to the Source Column Range.
Dim srg As Range
Dim isNotEmpty As Boolean
With wb.Worksheets(sName).Range(sFirst)
' Attempt to find the last non-empty cell.
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
' Validate the last non-empty cell.
If Not lCell Is Nothing Then
Set srg = .Resize(lCell.Row - .Row + 1)
isNotEmpty = True
End If
End With
' Write result to the Destination Column Range.
Dim rCount As Long
If isNotEmpty Then
' Write the values from the Source Column Range to the Source Array.
rCount = srg.Rows.Count
Dim sData As Variant
If rCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
' Create Destination Array.
Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
' Declare additional variables.
Dim sString As String, dString As String
Dim sr As Long, dr As Long
Dim isNotWritten As Boolean
' Loop through each element (row) of Source Array...
' ... and write the result to Destination Array.
For sr = 1 To rCount
sString = CStr(sData(sr, 1)) ' Trim(...) or Application.Trim(...)
If Len(sString) > 0 Then
If isNotWritten Then
dString = dString & dDelim & sString
Else
dString = sString
dr = sr
isNotWritten = True
End If
Else
If isNotWritten Then
dData(dr, 1) = dString
isNotWritten = False
End If
End If
Next sr
' Write last Destination String (to the Destination Array).
dData(dr, 1) = dString
' Write the values from the Destination Array
' to the Destination Column Range.
dCell.Resize(rCount).Value = dData
End If
' Clear the contents below the Destination Column Range
' ('whether there was data or not').
With dCell
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End With
End Sub
编辑：
- 以下是
ActiveSheet的修改版本(仅限一个工作表(，包括一个自动Trim(而非Application.Trim(，它将删除前导空格和尾随空格，但保留可能剩余的连续空格
Sub ParagraphingActiveSheet()
' Define constants.
Const sFirst As String = "A2"
Const dFirst As String = "B2"
Const dDelim As String = " "
' Create a reference to the first cell of the Destination Column Range.
Dim dCell As Range: Set dCell = ActiveSheet.Range(dFirst)
' Create a reference to the Source Column Range.
Dim srg As Range
Dim isNotEmpty As Boolean
With ActiveSheet.Range(sFirst)
' Attempt to find the last non-empty cell.
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
' Validate the last non-empty cell.
If Not lCell Is Nothing Then
Set srg = .Resize(lCell.Row - .Row + 1)
isNotEmpty = True
End If
End With
' Write result to the Destination Column Range.
Dim rCount As Long
If isNotEmpty Then
' Write the values from the Source Column Range to the Source Array.
rCount = srg.Rows.Count
Dim sData As Variant
If rCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
' Create Destination Array.
Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
' Declare additional variables.
Dim sString As String, dString As String
Dim sr As Long, dr As Long
Dim isNotWritten As Boolean
' Loop through each element (row) of Source Array...
' ... and write the result to Destination Array.
For sr = 1 To rCount
sString = Trim(CStr(sData(sr, 1)))
If Len(sString) > 0 Then
If isNotWritten Then
dString = dString & dDelim & sString
Else
dString = sString
dr = sr
isNotWritten = True
End If
Else
If isNotWritten Then
dData(dr, 1) = dString
isNotWritten = False
End If
End If
Next sr
' Write last Destination String (to the Destination Array).
dData(dr, 1) = dString
' Write the values from the Destination Array
' to the Destination Column Range.
dCell.Resize(rCount).Value = dData
End If
' Clear the contents below the Destination Column Range
' ('whether there was data or not').
With dCell
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End With
End Sub
要输出与段落对齐，请跟踪段落的起始位置。
像这样的
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim dat As Variant
Dim Result As Variant
Dim rw As Long
Dim rwOut As Long
Dim InPara As Boolean
Dim Sentance As String
Set ws = ActiveSheet
With ws
Set rng = .Range(.Cells(.Rows.Count, 1), .Cells(2, 1))
If rng.Row = 1 Then Exit Sub
dat = rng.Value2
End With
ReDim Result(1 To UBound(dat, 1), 1 To 1)
InPara = False
For rw = 1 To UBound(dat, 1)
If Not InPara And Trim$(dat(rw, 1)) <> vbNullString Then
InPara = True
rwOut = rw
ElseIf InPara And Trim(dat(rw, 1)) = vbNullString Then
InPara = False
Result(rwOut, 1) = Sentance
Sentance = vbNullString
End If
If InPara Then
Sentance = Sentance & " " & Trim(dat(rw, 1))
End If
Next
rng.Offset(, 1) = Result
End Sub