VBA将excel单元格中的多行文本拆分为单独的行并保留相邻的单元格值
请参阅显示我的数据和运行宏后预期数据的附加图像，
- 我想拆分 B 列中的多行单元格并在单独的行中列出并从第一个空格中删除文本。该值将被称为 SESE_ID，并且对于来自同一行的每个 SESE_ID 应该具有来自 C 列的规则。
- 如果 A 列中有多个前缀由逗号或空格逗号分隔，则对每个前缀重复上述值。
请有人帮助我在宏...
- 附加的第一张图片是示例源：
- 以下是宏：
子 Complete_sepy_load_macro()
将 ws、s1、s2 调暗为工作表
Dim rw、rw2、rw3、col1、count1、w、x、y、z、cw 作为整数
将 text1 调暗为字符串
Dim xwalk As String
Dim TOSes 作为变体
Application.DisplayAlerts = False
For each ws in Sheets
如果 ws.Name = "CMC_SEPY_SE_PYMT" 然后 Sheets("CMC_SEPY_SE_PYMT").Delete
下一个
Application.DisplayAlerts = True
设置 s2 = ActiveSheet
g = s2.Name
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) = "Service ID"
'规则栏
做
w = w + 1
循环直到左（s2.Cells（1，w），4）=“规则”
'人行横道
做
cw = cw + 1
循环直到左边(s2.Cells(1, cw).Value, 9) = "Crosswalk"
'Alt 规则列（位置派生自规则列）
'counts # "rule" 和 "alt rule" 之间的单元格，用作其余 "alt rule" 单元格的先例
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
做
If 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
循环直到匹配 = True
万一
万一
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(TOS) + 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)) "" 然后
如果 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
Dim wb 作为工作簿
Dim wss、wsSepy、wsSID 作为工作表 'SID = 服务 ID 电子表格
Dim sepyRow, sepyCol, acctCol, sidSeseCol, sidAcctCol, j As Long
将单元格调暗为范围
将单元格范围调暗为范围
将 topRow 调暗为范围
将 sepySese 调暗为字符串
MsgBox "全部设置，确保 SESE_RULE 列中没有 #N/A"
结束子
下图是我得到的输出：
问题：如果您看到源数据，我在 A 列中有 SEPY_PFX。我希望每个 SEPY 的每一行都重复。目前我的代码给了我 RULE 作为 SEPY_PFX，我仍在努力，但如果有人快速帮助我，我会很高兴，它已经超出了我的头脑。
此代码将适用于您发布的第一个示例，以提供您想要的输出：
原始来源：
原始结果：
它的工作原理是使用Class和Collections，一次创建一个条目，然后将它们放在一起以获得结果。
我使用数组来收集和输出数据，因为这会工作得更快。在你的原件中，你有一些字体着色，我已经继承了。
您应该能够使其适应您的真实数据，但是，如果您不能，我建议您在某些文件共享网站（例如 DropBox）上发布原始数据的“清理”副本，其中包含正确的列等， OneDrive等；并在此处发布链接，以便我们可以看到“真实的东西”
关于类的使用，请看 Chip Pearson的网站
另外，请阅读代码中的注释以获取解释和建议。
首先插入一个类模块，将其重命名为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
对代码中的 Worksheet 引用进行更改（只需在常规模块的开头执行此操作。
首先在您的原始示例上尝试此操作，以便您可以查看它是如何工作的，然后将额外的列添加到类和集合中并进行处理，或者在此处发布更多详细信息