我有一个充满数据的电子表格。在“H”列中，我有 3-7 个段落的单元格。理想情况下，我想将单元格拆分为 2 个段落最大长度单元格，并使用相同的规则合并其余段落。我有工作 VBA，可以在每个段落中执行此操作。最终目标是对包含大量文本的单元格的每“x”个段落（最好是“2”个段落）执行此操作。感谢您的指点！
我确实根据字符数简短地研究了分割字符串，但我的尝试弄乱了段落结尾。下面的代码还有一个问题是，它会在每个“Enter”键或新行与两段之后分割一个单元格。
Sub splitcells()
Dim InxSplit As Long
Dim SplitCell() As String
Dim RowCrnt As Long
With Worksheets("Sheet1")
RowCrnt = 10 ' The first row containing data.
Do While True
' * I use .Cells(row, column) rather than .Range because it is more
' convenient when you need to change the row and/or column numbers.
' * Note the column value can be a number or a column identifier.
' A = 1, B=2, Z=26, AA = 27, etc. I am not doing arithmetic with
' the columns so I have used "A" and "B" which I find more
' meaningful than 1 and 2.
If .Cells(RowCrnt, "H").Value = "" Then
Exit Do
End If
SplitCell = Split(.Cells(RowCrnt, "H").Value, Chr(10))
If UBound(SplitCell) > 0 Then
' The cell contained a line break so this row is to be spread across
' two or more rows.
' Update the current row
.Cells(RowCrnt, "H").Value = SplitCell(0)
' For each subsequent element of the split value, insert a row
' and place the appropriate values within it.
For InxSplit = 1 To UBound(SplitCell)
RowCrnt = RowCrnt + 1
' Push the rest of the worksheet down
.Rows(RowCrnt).EntireRow.Insert
' Select the appropriate part of the original cell for this row
.Cells(RowCrnt, "H").Value = SplitCell(InxSplit)
' Copy the value from column B from the previous row
.Cells(RowCrnt, "A").Value = .Cells(RowCrnt - 1, "A").Value
.Cells(RowCrnt, "B").Value = .Cells(RowCrnt - 1, "B").Value
.Cells(RowCrnt, "C").Value = .Cells(RowCrnt - 1, "C").Value
.Cells(RowCrnt, "D").Value = .Cells(RowCrnt - 1, "D").Value
.Cells(RowCrnt, "E").Value = .Cells(RowCrnt - 1, "E").Value
.Cells(RowCrnt, "F").Value = .Cells(RowCrnt - 1, "F").Value
.Cells(RowCrnt, "G").Value = .Cells(RowCrnt - 1, "G").Value
.Cells(RowCrnt, "I").Value = .Cells(RowCrnt - 1, "I").Value
.Cells(RowCrnt, "J").Value = .Cells(RowCrnt - 1, "J").Value
.Cells(RowCrnt, "K").Value = .Cells(RowCrnt - 1, "K").Value
.Cells(RowCrnt, "L").Value = .Cells(RowCrnt - 1, "L").Value
.Cells(RowCrnt, "M").Value = .Cells(RowCrnt - 1, "M").Value
.Cells(RowCrnt, "N").Value = .Cells(RowCrnt - 1, "N").Value
.Cells(RowCrnt, "O").Value = .Cells(RowCrnt - 1, "O").Value
Next
End If
RowCrnt = RowCrnt + 1
Loop
End With
End Sub
这是一种方法：
Sub splitcells()
Const SPLIT_PARAS As Long = 2 'split to this number of paragraphs in a cell
Dim ws As Worksheet, lr As Long, rw As Range, p As Long
Dim n As Long, arr, i, s As String, ub As Long, c As Range, sep As String
Set ws = ThisWorkbook.Worksheets(1)
lr = ws.Cells(Rows.Count, "H").End(xlUp).Row
'start at the bottom and loop up
Set rw = ws.Rows(lr).Range("A1:O1") 'range is *relative* to row...
Do While rw.Row >= 10 'loop over rows
Set c = rw.Columns("H")
If Len(c.Value) > 0 Then
arr = Split(c.Value, vbLf) 'split to array on newLine
ub = UBound(arr)
If ub > SPLIT_PARAS - 1 Then 'more paras than limit?
n = Application.Ceiling((ub + 1) / SPLIT_PARAS, 1) 'total rows required
rw.Offset(1).Resize(n - 1).EntireRow.Insert 'add rows below
rw.Offset(1).Resize(n - 1).Value = rw.Value 'copy row data to added rows
s = ""
p = 0
For i = 0 To ub 'loop over paragraphs and populate ColH on each line
p = p + 1
s = s & IIf(p > 1, vbLf, "") & arr(i)
If p = SPLIT_PARAS Then 'write accumulated string?
c.Value = s
Set c = c.Offset(1) 'next row down
s = "" 'clear string
p = 0 'reset count
End If
Next i
If p > 0 Then c.Value = s 'remainder?
End If 'needs to be split into additional rows
End If 'have value in H
Set rw = rw.Offset(-1) 'next row up
Loop
End Sub