VBA将excel单元格中的多行文本拆分为单独的行并保留相邻的单元格值

Question

请查看附件图片，其中显示了运行宏后我的数据和预期数据，

• 我想拆分 B 列中的多行单元格并在单独的行中列出并从第一个空格中删除文本。此值将被称为 SESE_ID，并且对于同一行中的每个 SESE_ID，应具有 C 列中的 RULE。
• 如果 A 列中有多个前缀，用逗号或空格逗号分隔，则对每个前缀重复上述值。

请有人在宏中帮助我...

1. 附上的第一张图片是示例来源：

1. 以下是宏：

子 Complete_sepy_load_macro() 暗淡 ws, s1, s2 作为工作表 Dim rw, rw2, rw3, col1, count1, w, x, y, z, cw As Integer 将 text1 调暗为字符串 将 xwalk 调暗为字符串 将 TOS 变暗为变体 Application.DisplayAlerts = False 对于表格中的每个 ws 如果 ws.Name = "CMC_SEPY_SE_PYMT" 然后 Sheets("CMC_SEPY_SE_PYMT").Delete 下一个 Application.DisplayAlerts = True 设置 s2 = ActiveSheet g = s2.名称 Sheets.Add.Name = "CMC_SEPY_SE_PYMT" 设置 s1 = Sheets("CMC_SEPY_SE_PYMT") s1.Cells(1, 1) = "SEPY_PFX" s1.Cells(1, 2) = "SEPY_EFF_DT" s1.Cells(1, 3) = "SESE_ID" s1.Cells(1, 4) = "SEPY_TERM_DT" s1.Cells(1, 5) = "SESE_RULE" s1.Cells(1, 6) = "SEPY_EXP_CAT" s1.Cells(1, 7) = "SEPY_ACCT_CAT" s1.Cells(1, 8) = "SEPY_OPTS" s1.Cells(1, 9) = "SESE_RULE_ALT" s1.Cells(1, 10) = "SESE_RULE_ALT_COND" s1.Cells(1, 11) = "SEPY_LOCK_TOKEN" s1.Cells(1, 12) = "ATXR_SOURCE_ID" s1.Range("A:A").NumberFormat = "@" s1.Range("B:B").NumberFormat = "m/d/yyyy" s1.Range("C:C").NumberFormat = "@" s1.Range("D:D").NumberFormat = "m/d/yyyy" s1.Range("E:E").NumberFormat = "@" s1.Range("F:F").NumberFormat = "@" s1.Range("G:G").NumberFormat = "@" s1.Range("H:H").NumberFormat = "@" s1.Range("I:I").NumberFormat = "@" s1.Range("J:J").NumberFormat = "@" s1.Range("K:K").NumberFormat = "0" s1.Range("L:L").NumberFormat = "m/d/yyyy" rw2 = 2 x = 1 y = 1 z = 1 '服务标识栏 做 y = y + 1 循环直到 s2.Cells(1, y) = "服务 ID" '规则栏 做 w = w + 1 循环直到左边（s2.Cells（1，w），4）=“规则” '人行横道栏 做 cw = cw + 1 循环直到左边(s2.Cells(1, cw).Value, 9) = "Crosswalk" 'Alt 规则列（从规则列派生的位置） '计算“规则”和“替代规则”之间的单元格数，用作其余“替代规则”单元格的先例 ar = w 做 ar = ar + 1 循环直到左边(s2.Cells(1, ar).Value, 3) = "Alt" ar = ar - w '前缀行 做 x = x + 1 循环直到 s2.Cells(x, w) "" '第一个服务ID行 做 z = z + 1 循环直到 s2.Cells(z, y) "" '将 rw = z + 2 更改为 rw = z，跳过前两行 对于 rw = z 到 s2.Range("a65536").End(xlUp).Row 如果 s2.Cells(rw, y) "" 那么 如果 InStr(1, s2.Cells(rw, y), Chr(10)) 0 那么 TOSes = Split(s2.Cells(rw, y).Value, Chr(10)) 'Chr(10) 是“换行”字符 计数1 = 0 做 如果 Trim(TOSes(count1)) "" 那么 对于 col1 = w 到 s2.UsedRange.Columns.Count If Left(s2.Cells(1, col1), 4) = "Rule" Then 如果 InStr(1, TOSes(count1), " ") > 0 那么 s1.Cells(rw2, 3) = Trim(Left(TOSes(count1), InStr(1, TOSes(count1), " "))) 'sese 别的 s1.Cells(rw2, 3) = TOSes(count1) 万一 s1.Cells(rw2, 1) = s2.Cells(x, col1) '前缀 s1.Cells(rw2, 5) = s2.Cells(rw, col1) '规则 '使用人行横道服务ID填充alt规则 如果 s2.Cells(rw, cw).Value "" 那么 如果 xwalk = "" 那么 匹配 = 假 xwalk = Trim(s2.Cells(rw, cw)) & "" rwcw = z 做 如果 InStr(1, s2.Cells(rwcw, y).Value, xwalk, vbTextCompare) > 0 那么 '获取规则并写入当前行的alt规则列 s2.Cells(rw, col1).Offset(0, ar).Value = s2.Cells(rwcw, w).Value 匹配 = 真 万一 rwcw = rwcw + 1 循环直到匹配=真 万一 万一 s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt 规则 s1.Cells(rw2, 7) = "待定" 'cac s1.Cells(rw2, 13) = s2.Name '文件 rw2 = rw2 + 1 万一 xwalk = "" 下一个 col1 万一 计数1 = 计数1 + 1 循环直到 count1 = UBound(TOSes) + 1 别的 对于 col1 = w 到 s2.UsedRange.Columns.Count If Left(s2.Cells(1, col1), 4) = "Rule" Then 如果 InStr(1, s2.Cells(rw, y), " ") > 0 那么 s1.Cells(rw2, 3) = Trim(Left(s2.Cells(rw, y), 4)) 'sese 别的 s1.Cells(rw2, 3) = s2.Cells(rw, y) 万一 s1.Cells(rw2, 1) = s2.Cells(x, col1) '前缀 s1.Cells(rw2, 5) = s2.Cells(rw, col1) '规则 s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt 规则 s1.Cells(rw2, 7) = "待定" 'cac s1.Cells(rw2, 13) = s2.Name '文件 rw2 = rw2 + 1 万一 下一个 col1 万一 ElseIf s2.Cells(rw, y) = "" And Trim(s2.Cells(rw, w)) "" Then 如果 Len(s2.Cells(rw, 1)) >= 10 那么 text1 = Left(s2.Cells(rw, 1), 10) & " |row: " & rw 'sese 别的 text1 = s2.Cells(rw, 1) & " row: " & rw 'sese 万一 对于 col1 = w 到 s2.UsedRange.Columns.Count If Left(s2.Cells(1, col1), 4) = "Rule" Then s1.Cells(rw2, 3) = text1 'sese s1.Cells(rw2, 3).Interior.ColorIndex = 6 s1.Cells(rw2, 1) = s2.Cells(x, col1) '前缀 s1.Cells(rw2, 5) = s2.Cells(rw, col1) '规则 s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt 规则 s1.Cells(rw2, 7) = "待定" 'cac s1.Cells(rw2, 13) = s2.Name '文件 rw2 = rw2 + 1 万一 下一个 col1 万一 下一个 对于 rw3 = 2 到 s1.UsedRange.Rows.Count s1.Cells(rw3, 2) = "1/1/2009" s1.Cells(rw3, 4) = "12/31/9999" s1.Cells(rw3, 11) = 1 s1.Cells(rw3, 12) = "1/1/1753" 下一个 rw3 将 wb 调暗为工作簿 Dim wss, wsSepy, wsSID As Worksheet 'SID = 服务 ID 电子表格 暗淡 sepyRow, sepyCol, acctCol, sidSeseCol, sidAcctCol, j As Long 将单元格调暗为范围 将单元格范围变暗为范围 将 topRow 作为范围调暗 将 sepySese 调暗为字符串 MsgBox "全部设置，确保 SESE_RULE 列中没有 #N/A" 结束子

1. 下图是我得到的输出：

2. 问题：如果您看到源数据，我在 A 列中有 SEPY_PFX。我希望为每个 SEPY 重复每一行。目前我的代码给了我作为 SEPY_PFX 的 RULE，我仍在努力，但如果有人能快速帮助我，我会很高兴，它已经超出了我的想象。

Answer 1

此代码适用于您发布的第一个示例，以提供您想要的输出：

原文来源：

原始结果：

它的工作原理是使用 Class 和 Collections，一次创建一个条目，然后将它们放在一起以获得结果。

我使用数组来收集和输出数据，因为这样会更快。在您的原件中，您有一些字体颜色，我已经沿用了。

您应该能够使其适应您的真实数据，但如果不能，我建议您在某些文件共享网站上发布原始数据的“净化”副本，包括正确的列等如 DropBox、OneDrive 等；并在此处发布链接，以便我们可以看到“真实的东西”

关于类的使用，请看Chip Pearson's web site

另外，请阅读代码中的 cmets 以获得解释和建议。

首先插入一个类模块，将其重命名为cOfcCode并将下面的代码粘贴到其中：

'Will need to add properties for the additional columns

Option Explicit

Private pSEPY As String
Private pFontColor As Long
Private pSESE As String
Private pRule As String

Public Property Get SEPY() As String
    SEPY = pSEPY
End Property
Public Property Let SEPY(Value As String)
    pSEPY = Value
End Property

Public Property Get FontColor() As Long
    FontColor = pFontColor
End Property
Public Property Let FontColor(Value As Long)
    pFontColor = Value
End Property

Public Property Get Rule() As String
    Rule = pRule
End Property
Public Property Let Rule(Value As String)
    pRule = Value
End Property

Public Property Get SESE() As String
    SESE = pSESE
End Property
Public Property Let SESE(Value As String)
    pSESE = Value
End Property

然后，在常规模块中：

Option Explicit
Sub ReformatData()
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim vSEPY As Variant, vSESE As Variant
    Dim cOC As cOfcCode
    Dim colOC As Collection
    Dim lRGB As Long
    Dim I As Long, J As Long, K As Long

'Change Sheet references as needed
Set wsSrc = Worksheets("Sheet2")
Set wsRes = Worksheets("Sheet3")

'Assuming Data is in Columns A:C
With wsSrc
    Set rSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
End With
Set rRes = wsRes.Range("A1")

vSrc = rSrc
Set colOC = New Collection  'Collection of each "to be" row
For I = 2 To UBound(vSrc, 1)

    'Split SEPY_PFX into relevant parts
    vSEPY = Split(vSrc(I, 1), ",")
    For J = 0 To UBound(vSEPY)

        'Get the font color from the original cell
        With rSrc(I, 1)
            lRGB = .Characters(InStr(1, .Value, vSEPY(J), vbTextCompare), 1).Font.Color
        End With

        'Split SESE_ID into relevant parts
        vSESE = Split(vSrc(I, 2), vbLf)

        'Iterate through each SESE_ID, picking up the SEPY_PFX, and RULE
        For K = 0 To UBound(vSESE)
            Set cOC = New cOfcCode

            'Will need to adjust for the extra columns
            With cOC
                .FontColor = lRGB
                .Rule = vSrc(I, 3)
                .SEPY = vSEPY(J)
                .SESE = vSESE(K)
                colOC.Add cOC '<-- ADD to the collection
            End With
        Next K
    Next J
Next I

'Put together the Results
ReDim vRes(0 To colOC.Count, 1 To UBound(vSrc, 2))

'Copy the column headings from the source
For I = 1 To UBound(vRes, 2)
    vRes(0, I) = vSrc(1, I)
Next I

'Will need to add entries for the other columns
For I = 1 To colOC.Count
    With colOC(I)
        vRes(I, 1) = .SEPY
        vRes(I, 2) = .SESE
        vRes(I, 3) = .Rule
    End With
Next I

'Clear the results worksheet and write the results
wsRes.Cells.Clear
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
rRes = vRes

'Add the correct font color and format
For I = 1 To colOC.Count
    rRes.Rows(I + 1).Font.Color = colOC(I).FontColor
Next I

With rRes.Rows(1)
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With

rRes.EntireColumn.AutoFit

End Sub

对代码中的工作表引用进行更改（只需要在常规模块的开头进行。

首先在您的原始示例上尝试此操作，这样您就可以了解它是如何工作的，然后将额外的列和处理添加到类和集合中，或者在此处发布更多详细信息

Answer 2

我假设原始数据在工作表“DATA”中，并且用于存储处理数据的工作表“Expected Output”已经存在。

您的代码将是：大多数行的操作由 cmets 解释（“'”右侧）

Sub processData()
Dim oWS As Worksheet, pWS As Worksheet
Dim oRow As Long, pRow As Long
Dim splitMultiLine As String, splitPerfix As String
Dim c As Long, i As Long, j As Long, k As Long
Dim prefixes As Variant, lines As Variant
Dim dataACol As String, dataBCol As String, dataCCol As String


Set oWS = Worksheets("DATA") 'original data
Set pWS = Worksheets("Expected Output") 'processed data

'Copy title row
For c = 1 To 3
  pWS.Cells(1, c) = oWS.Cells(1, c)
Next c

oRow = 2 ' row of oWS
pRow = 2 ' row of pWS

With oWS
  While (.Cells(oRow, 1) <> "") 'Loop while A colmn has value
    dataACol = .Cells(oRow, 1) 'data in A column
    dataBCol = .Cells(oRow, 2) 'data in B column
    dataCCol = .Cells(oRow, 3) 'data in C colum

    prefixes = Split(dataACol, ",") ' split prefixes by comma
    lines = Split(dataBCol, Chr(10)) ' split multi lines in a cell by newline (Char(10))

    For i = LBound(prefixes) To UBound(prefixes)
      For j = LBound(lines) To UBound(lines)
        pWS.Cells(pRow, 1) = Trim(prefixes(i)) ' A column of output
        k = InStr(lines(j), " ")
        pWS.Cells(pRow, 2) = Left(lines(j), k - 1) ' B column of output
        pWS.Cells(pRow, 3) = dataCCol ' C column of output
        pRow = pRow + 1
      Next j
    Next i
    oRow = oRow + 1
  Wend
End With
End Sub