Question

我正在使用宏将现有单元格中的换行符分隔为新行。我已经解决了这个问题。现在我想添加一个列，该列对分隔的每一行进行编号。

单格

所有信息

旧设置（多行，一列）

第1行信息

第2行信息

第3行信息

所需的设置（多行，两列）

1行1信息

2行2信息

3行3信息

我想在宏开始分解新单元格时启动序列。

这是我正在使用的代码。任何帮助将不胜感激！

Sub CellSplitter()
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

iColumn = 5

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

Answer 1

这样的事情对你有用：

Sub tgr()

    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim vLine As Variant
    Dim aData As Variant
    Dim aResults() As Variant
    Dim ResultIndex As Long
    Dim lCount As Long
    Dim lSplitCol As Long
    Dim i As Long, j As Long

    With ActiveWorkbook
        Set wsData = .ActiveSheet
        Set wsDest = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    End With

    lSplitCol = 5

    aData = wsData.Range("A1").CurrentRegion.Value
    ReDim aResults(1 To 65000, 1 To UBound(aData, 2) + 1)

    ResultIndex = 0
    For i = LBound(aData, 1) To UBound(aData, 1)
        lCount = 0
        For Each vLine In Split(aData(i, lSplitCol), Chr(10))
            lCount = lCount + 1
            ResultIndex = ResultIndex + 1
            aResults(ResultIndex, 1) = lCount
            For j = LBound(aData, 2) To UBound(aData, 2)
                If j = lSplitCol Then
                    aResults(ResultIndex, j + 1) = vLine
                Else
                    aResults(ResultIndex, j + 1) = aData(i, j)
                End If
            Next j
            If ResultIndex = UBound(aResults, 1) Then
                wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
                ReDim aResults(1 To 65000, 1 To UBound(aData, 2) + 1)
                ResultIndex = 0
            End If
        Next vLine
    Next i

    If ResultIndex > 0 Then wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(ResultIndex, UBound(aResults, 2)).Value = aResults
    wsDest.Rows(1).EntireRow.Delete xlUp

End Sub

换行添加编号列的新行

1 个答案: