Question

我试图弄清楚如何拆分数据行，其中行中的列B，C，D包含多行而其他行则不包含。如果我将这些列复制到新工作表中，手动插入行，然后运行下面的宏（这仅仅是针对A列），我已经弄明白了如何拆分多行单元格，但我和＃39;在编写其余部分时丢失了。

这里的数据是什么样的： enter image description here

因此对于第2行，我需要将它分成6行（单元格B2中每行一行），A2中的单元格A2中的文本：A8。我还需要将C和D列拆分为B，然后列E：CP 与A列相同。

以下是我在B，C，D列中分割单元格的代码：

Dim iPtr As Integer
Dim iBreak As Integer
Dim myVar As Integer
Dim strTemp As String
Dim iRow As Integer
iRow = 0
For iPtr = 1 To Cells(Rows.Count, col).End(xlUp).Row
    strTemp = Cells(iPtr1, 1)
    iBreak = InStr(strTemp, vbLf)
    Range("C1").Value = iBreak
        Do Until iBreak = 0
        If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
            iRow = iRow + 1
            Cells(iRow, 2) = Left(strTemp, iBreak - 1)
        End If
        strTemp = Mid(strTemp, iBreak + 1)
        iBreak = InStr(strTemp, vbLf)
    Loop
    If Len(Trim(strTemp)) > 0 Then
        iRow = iRow + 1
        Cells(iRow, 2) = strTemp
    End If
Next iPtr
End Sub

以下是示例文件的链接（请注意，此文件有4行，实际工作表超过600行）：https://www.dropbox.com/s/46j9ks9q43gwzo4/Example%20Data.xlsx?dl=0

Answer 1

这是一个相当有趣的问题，而且我之前看到过各种变化。我继续为它写了一个通用的解决方案，因为它似乎是一个有用的代码保留给自己。

我对数据的假设几乎只有两个：

返回值由Chr(10)或vbLf常量表示。
属于较低行的数据具有足够的回报以使其排成一行。这似乎是你的情况，因为有返回字符似乎可以按照你想要的方式排列。

输出图片，缩小显示A:D的所有数据。请注意，下面的代码默认处理所有列并输出到新工作表。你可以根据需要限制列，但太很容易使它变得通用。

output of the code

<强>代码

Sub SplitByRowsAndFillBlanks()

    'process the whole sheet, could be
    'Intersect(Range("B:D"), ActiveSheet.UsedRange)
    'if you just want those columns
    Dim rng_all_data As Range
    Set rng_all_data = Range("A1").CurrentRegion

    Dim int_row As Integer
    int_row = 0

    'create new sheet for output
    Dim sht_out As Worksheet
    Set sht_out = Worksheets.Add

    Dim rng_row As Range
    For Each rng_row In rng_all_data.Rows

        Dim int_col As Integer
        int_col = 0

        Dim int_max_splits As Integer
        int_max_splits = 0

        Dim rng_col As Range
        For Each rng_col In rng_row.Columns

            'splits for current column
            Dim col_parts As Variant
            col_parts = Split(rng_col, vbLf)

            'check if new max row count
            If UBound(col_parts) > int_max_splits Then
                int_max_splits = UBound(col_parts)
            End If

            'fill the data into the new sheet, tranpose row array to columns
            sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)

            int_col = int_col + 1
        Next

        'max sure new rows added for total length
        int_row = int_row + int_max_splits + 1
    Next

    'go through all blank cells and fill with value from above
    Dim rng_blank As Range
    For Each rng_blank In sht_out.Cells.SpecialCells(xlCellTypeBlanks)
        rng_blank = rng_blank.End(xlUp)
    Next

End Sub

工作原理

代码中有注释以突出显示正在发生的事情。以下是高级概述：

总的来说，我们遍历数据的每一行，分别处理所有列。
使用Split，当前单元格的文本为vbLf。这给出了所有单独行的数组。
计数器正在跟踪添加的最大行数（实际上这是rows-1，因为这些数组是0-indexed。
现在可以将数据输出到新工作表。这很简单，因为我们可以转储Split为我们创建的数组。唯一棘手的部分是让它到达工作表上的正确位置。为此，有一个当前列偏移的计数器和一个全局计数器来确定需要偏移的总行数。 Offset将我们带到了正确的牢房; Resize确保输出所有行。最后，需要Application.Transpose因为Split返回一个行数组而我们正在转储一列。
更新计数器。列偏移每次递增。更新行偏移量以添加足够的行以覆盖最后一个最大值（+1，因为这是0-indexed）
最后，我在所有空白单元格中找到use my waterfall fill (your previous question)以确保没有空白。我放弃了错误检查，因为我认为存在空白。

Answer 2

感谢您提供样品。这个任务非常有趣，我想为此编写代码。非常欢迎您将其调整到令您满意的程度，我希望您的团队将来可以使用RDBMS来管理此类数据。

Sub OrganizeSheet()

    Dim LastRow As Integer
    LastRow = GetLastRow()

    Dim Barray() As String
    Dim Carray() As String
    Dim Darray() As String
    Dim LongestArray As Integer
    Dim TempInt As Integer

    Dim i As Integer
    i = 1

    Do While i <= LastRow

        Barray = Split(Range("B" & i), Chr(10))
        Carray = Split(Range("C" & i), Chr(10))
        Darray = Split(Range("D" & i), Chr(10))
        LongestArray = GetLongestArray(Barray, Carray, Darray)

        If LongestArray > 0 Then

            ' reset the values of B, C and D columns
            On Error Resume Next
            Range("B" & i).Value = Barray(0)
            Range("C" & i).Value = Carray(0)
            Range("D" & i).Value = Darray(0)
            Err.Clear
            On Error GoTo 0

            ' duplicate the row multiple times
            For TempInt = 1 To LongestArray

                Rows(i & ":" & i).Select
                Selection.Copy

                Range(i + TempInt & ":" & i + TempInt).Select
                Selection.Insert Shift:=xlDown

                ' as each row is copied, change the values of B, C and D columns
                On Error Resume Next
                Range("B" & i + TempInt).Value = Barray(TempInt)
                If Err.Number > 0 Then Range("B" & i + TempInt).Value = ""
                Err.Clear
                Range("C" & i + TempInt).Value = Carray(TempInt)
                If Err.Number > 0 Then Range("C" & i + TempInt).Value = ""
                Err.Clear
                Range("D" & i + TempInt).Value = Darray(TempInt)
                If Err.Number > 0 Then Range("D" & i + TempInt).Value = ""
                Err.Clear
                On Error GoTo 0

                Application.CutCopyMode = False

            Next TempInt

            ' increment the outer FOR loop's counters
            LastRow = LastRow + LongestArray
            i = i + LongestArray

        End If

        i = i + 1
    Loop

End Sub

' ----------------------------------

Function GetLongestArray(ByRef Barray() As String, ByRef Carray() As String, ByRef Darray() As String)
    GetLongestArray = UBound(Barray)
    If UBound(Carray) > GetLongestArray Then GetLongestArray = UBound(Carray)
    If UBound(Darray) > GetLongestArray Then GetLongestArray = UBound(Darray)
End Function

' ----------------------------------

Function GetLastRow() As Integer
    Worksheets(1).Select
    Range("A1").Select
    Selection.End(xlDown).Select
    GetLastRow = Selection.Row
    Range("A1").Select
End Function

试一试！

拆分具有多行文本和单行文本的行

2 个答案: