VBA宏输出显示在一行中，因此如何将其设置为多列

这是VBscript正在生成的当前输出

ID            DESCRIPTION 1          RECURSIVE_ANALYSIS

CM-1           xxxxxxxxxxxx            Issue A
                                          Sub issue a
                                          Sub issue b
                                          Sub issue c

CM-2           yyyyyyyyyyy             Issue B
                                            Sub issue a
                                            Sub issue b

下面是我为获得输出而设计的VBA代码

Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer

iColumn = 3

Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add

iTargetRow = 0
With wksSource
    lNumCols = .Range("IV1").End(xlToLeft).Column
    lNumRows = .Range("A65536").End(xlUp).Row
    For J = 1 To lNumRows
        CText = .Cells(J, iColumn).Value
        Temp = Split(CText, Chr(10))
        For K = 0 To UBound(Temp)
            iTargetRow = iTargetRow + 1
            For L = 1 To lNumCols
                If L <> iColumn Then
                    wksNew.Cells(iTargetRow, L) _
                      = .Cells(J, L)
                Else
                    wksNew.Cells(iTargetRow, L) _
                      = Temp(K)
                End If
            Next L
        Next K
    Next J
End With

那么，有人能帮我弄清楚如何得到预期的输出吗

任何帮助都将不胜感激

---

谢谢你

看来你没有展示整个故事，所以这里有一个猜测：

在您的代码之后放置以下内容

With wksNew' reference 'wksNew' sheet
    With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
        .Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
        .Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
        .Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
        .Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
    End With
    .Columns.AutoFit 'adjust your columns width
End With

---

使用Variant数组更简单

Sub test()
    Dim r As Long, c As Integer
    Dim j As Integer
    Dim k As Integer
    Dim wksNew As Worksheet
    Dim wksSource As Worksheet
    Dim vDB, vSplit, vR()

    Set wksSource = ActiveSheet
    Set wksNew = Worksheets.Add

    With wksSource
        c = .Range("IV1").End(xlToLeft).Column
        r = .Range("A65536").End(xlUp).Row
        vDB = .Range("a1", .Cells(r, c))
        For i = 1 To r
            vSplit = Split(vDB(i, c), Chr(10))
            For k = 1 To UBound(vSplit)
                n = n + 1
                ReDim Preserve vR(1 To c + 1, 1 To n)
                If k = 1 Then
                    For j = 1 To c - 1
                        vR(j, n) = vDB(i, j)
                    Next j
                    vR(c, n) = vSplit(k - 1)
                    vR(c + 1, n) = vSplit(k)
                Else
                    vR(c + 1, n) = vSplit(k)
                End If
            Next k
        Next i
    End With
    Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
    Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub

---

下面是VBscript代码正在生成的当前输出的示例

[1]：

这是我预期输出的示例

[1]：

请告诉我你的建议

---

谢谢

您能否提供一些示例数据，或者至少向我们展示一下is的外观，以便更好地了解代码正在处理的内容。我猜测您的第三个循环逻辑，但这只是猜测。您的示例没有说明第三列中的数据为什么或如何缩进子问题。您能否发布一个带有可见单元格bord的屏幕截图ers？感谢您的回复。是的，我正在添加当前输出和预期输出的屏幕截图。这是VBscript代码生成的当前输出示例。[[1]：这是我预期输出的示例[[1]请告诉我你的建议@teylyn@QHarr：这是VBscript代码正在生成的当前输出示例这是我的预期输出示例请告诉我您的建议。这是VBscript代码正在生成的当前输出示例。[[1]：这是我的预期输出示例[[1]字体请告诉我你的建议。谢谢

Sub test()
    Dim r As Long, c As Integer
    Dim j As Integer
    Dim k As Integer
    Dim wksNew As Worksheet
    Dim wksSource As Worksheet
    Dim vDB, vSplit, vR()

    Set wksSource = ActiveSheet
    Set wksNew = Worksheets.Add

    With wksSource
        c = .Range("IV1").End(xlToLeft).Column
        r = .Range("A65536").End(xlUp).Row
        vDB = .Range("a1", .Cells(r, c))
        For i = 1 To r
            vSplit = Split(vDB(i, c), Chr(10))
            For k = 1 To UBound(vSplit)
                n = n + 1
                ReDim Preserve vR(1 To c + 1, 1 To n)
                If k = 1 Then
                    For j = 1 To c - 1
                        vR(j, n) = vDB(i, j)
                    Next j
                    vR(c, n) = vSplit(k - 1)
                    vR(c + 1, n) = vSplit(k)
                Else
                    vR(c + 1, n) = vSplit(k)
                End If
            Next k
        Next i
    End With
    Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
    Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub