Question

试图在VBA中使用它，效果很好。但是，我希望它可以在E和F的整个列上运行。怎么可能呢？

Sub SplitText()
    Dim MaxSize As Integer
    Dim rng As Range

    Set rng = Range("E1:F1")
    MaxSize = 0

    For Each cell In rng
        Dim CurrentSize As Integer
        CurrentSize = UBound(Split(cell.Value, vbLf))

        If CurrentSize > MaxSize Then
            MaxSize = CurrentSize
        End If
    Next

    Rows((rng.Row + 1) & ":" & (rng.Row + MaxSize)).Insert Shift:=xlDown

    For Each cell In rng
        Dim SplitText
        SplitText = Split(cell.Value, vbLf)
        cell.Resize(UBound(SplitText) + 1).Value = Application.Transpose(SplitText)
    Next

End Sub

Answer 1

尝试从底部到顶部插入的循环。

Sub splitMany()

    Dim i As Long, valE As Variant, valF As Variant

    With Worksheets("sheet13")

        For i = .Cells(.Rows.Count, "E").End(xlUp).row To 2 Step -1
            valE = Split(.Cells(i, "E").Value2, Chr(10))
            valF = Split(.Cells(i, "F").Value2, Chr(10))
            If UBound(valE) > 0 Or UBound(valF) > 0 Then
                .Cells(i, "E").Resize(Application.Max(UBound(valE), UBound(valF)), 1).EntireRow.Insert shift:=xlDown
                .Cells(i, "E").Resize(UBound(valE) + 1, 1) = Application.Transpose(valE)
                .Cells(i, "F").Resize(UBound(valF) + 1, 1) = Application.Transpose(valF)
            End If
        Next i

    End With

End Sub

Answer 2

我将原始数据读取到VBA数组中，并将每一行创建为集合的元素。如果您有大量数据，这将比对工作表进行多次读取/写入要快。

代码中的注释很重要。按照编写的方式，结果将放在不同的工作表上，但是您可以通过更改wsRes和rRes的位置来覆盖原始文件。

要进行检查以确保Colour和Name of Guest(s)列中“行”的数量相同，否则例程将无法完成。如果您希望其他事情发生，则需要指定它。

有一个格式化部分，您可以在其中做几乎想做的事。

Option Explicit
Sub reOrganize()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim col As Collection
    Dim I As Long, J As Long
    Dim V(1 To 6), V1, V2, W

Set wsSrc = Worksheets("sheet1")

'If want to overwrite original data, just change below to reflect
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Cells.Find(what:="S/N", after:=.Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues, _
        lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False).CurrentRegion
End With

'Collect the data
Set col = New Collection
For I = 2 To UBound(vSrc)
    V1 = Split(vSrc(I, 5), vbLf)
    V2 = Split(vSrc(I, 6), vbLf)
        If UBound(V1) <> UBound(V2) Then
            MsgBox "Color not matching with guest on line " & I
            Exit Sub
        End If
    For J = 0 To UBound(V1)
        V(1) = vSrc(I, 1)
        V(2) = vSrc(I, 2)
        V(3) = vSrc(I, 3)
        V(4) = vSrc(I, 4)
        V(5) = V1(J)
        V(6) = V2(J)
        col.Add V
    Next J
Next I

ReDim vRes(0 To col.Count, 1 To 6)

'Headers
For J = 1 To UBound(vRes, 2)
    vRes(0, J) = vSrc(1, J)
Next J

'data
I = 0
For Each W In col
    I = I + 1
    For J = 1 To 6
        vRes(I, J) = W(J)
    Next J
Next W

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes

'Formatting stuff
'Modify however you like
 .Style = "Output"
    With .Rows(1).Font
        .Size = .Size + 2
    End With
    .EntireColumn.AutoFit
    With .Offset(rowoffset:=1).Resize(rowsize:=.Rows.Count - 1)
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=" & rRes.Cells(2, 1).Address(False, False) & "=" & rRes.Cells(1, 1).Address(False, False)
        .FormatConditions(1).Font.Color = rRes.Cells(2, 1).Interior.Color
    End With

End With

End Sub

原始数据

结果

将多行单元格拆分为下面的新行

2 个答案: