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

我想弄清楚如何拆分行中的列B，C，D包含多行和其他人不行的数据行。 我已经想出了如何分割多行单元格，如果我只复制这些列到一个新的工作表，手动插入行，然后运行下面的macros（这只是列A），但我迷失在编码rest。

这里是数据的样子：

所以对于第2行，我需要将它拆分成6行（单元格B2中的每行一个），并使用A2：A8中的单元格A2中的文本。 我也需要列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

这是一个相当有趣的问题，我曾经看到过的变化。 我继续写了一个通用的解决scheme，因为它似乎是一个有用的代码保持自己。

关于数据我几乎只有两个假设：

• 返回值由Chr(10)表示，或者是vbLf常数。
• 属于较低行的数据具有足够的回报以使其排队。 这似乎是你的情况，因为有返回字符，似乎使事情排队你想要的。

输出的图片 ，缩小以显示A:D所有数据。 请注意，下面的代码默认处理所有的列，并输出到一个新的工作表 。 如果你愿意的话，你可以限制这些列，但是把它作为一般来说太诱人了。

码

 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 

怎么运行的

代码中有评论来强调正在发生的事情。 这是一个高层次的概述：

• 总的来说，我们遍历数据的每一行，分别处理所有的列。
• 当前单元格的文本是使用vbLf Split的。 这给出了所有单独的行的数组。
• 计数器正在跟踪添加的最大行数（实际上这是rows-1因为这些数组是0-indexed 。
• 现在数据可以输出到新的工作表。 这很简单，因为我们可以转储Split为我们创build的数组。 唯一棘手的部分是把它放在表单上的正确位置。 为此，存在用于当前列偏移的计数器和用于确定需要偏移多less总行的全局计数器。 Offset将我们移动到正确的单元格; Resize确保所有行都输出。 最后， Application.Transpose是需要的，因为Split返回一个行数组，我们正在倾销一个列。
• 更新计数器。 列偏移量每次都会增加。 行偏移量被更新以添加足够的行来覆盖最后的最大值（ +1因为这是0-indexed ）
• 最后，我在所有创build的空白单元格上使用我的瀑布填充（您的上一个问题） ，以确保没有空白。 我放弃错误检查，因为我认为空白存在。

Answer 2

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

 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 

试一试！