请参阅附加图像，其中显示了运行宏后我的数据和预期数据，
请有人在宏观上帮助我...
Sub Complete_sepy_load_macro()
Dim ws, s1, s2 As Worksheet
Dim rw, rw2, rw3, col1, count1, w, x, y, z, cw As Integer
Dim text1 As String
Dim xwalk As String
Dim TOSes As Variant
Application.DisplayAlerts = False
For Each ws In Sheets
If ws.Name = "CMC_SEPY_SE_PYMT" Then Sheets("CMC_SEPY_SE_PYMT").Delete
Next
Application.DisplayAlerts = True
Set s2 = ActiveSheet
g = s2.Name
Sheets.Add.Name = "CMC_SEPY_SE_PYMT"
Set 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
'service id column
Do
y = y + 1
Loop Until s2.Cells(1, y) = "Service ID"
'Rule column
Do
w = w + 1
Loop Until Left(s2.Cells(1, w), 4) = "Rule"
'Crosswalk column
Do
cw = cw + 1
Loop Until Left(s2.Cells(1, cw).Value, 9) = "Crosswalk"
'Alt rule column (location derived from rule column)
'counts # of cells between "rule" and "alt rule", used as precedent for rest of "alt rule" cells
ar = w
Do
ar = ar + 1
Loop Until Left(s2.Cells(1, ar).Value, 3) = "Alt"
ar = ar - w
'prefix row
Do
x = x + 1
Loop Until s2.Cells(x, w) ""
'first service id row
Do
z = z + 1
Loop Until s2.Cells(z, y) ""
'change rw = z + 2 to rw = z, was skipping first two rows
For rw = z To s2.Range("a65536").End(xlUp).Row
If s2.Cells(rw, y) "" Then
If InStr(1, s2.Cells(rw, y), Chr(10)) 0 Then
TOSes = Split(s2.Cells(rw, y).Value, Chr(10)) 'Chr(10) is the "new line" character
count1 = 0
Do
If Trim(TOSes(count1)) "" Then
For col1 = w To s2.UsedRange.Columns.Count
If Left(s2.Cells(1, col1), 4) = "Rule" Then
If InStr(1, TOSes(count1), " ") > 0 Then
s1.Cells(rw2, 3) = Trim(Left(TOSes(count1), InStr(1, TOSes(count1), " "))) 'sese
Else
s1.Cells(rw2, 3) = TOSes(count1)
End If
s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
'use crosswalk service id to populate alt rule
If s2.Cells(rw, cw).Value "" Then
If xwalk = "" Then
Match = False
xwalk = Trim(s2.Cells(rw, cw)) & " "
rwcw = z
Do
If InStr(1, s2.Cells(rwcw, y).Value, xwalk, vbTextCompare) > 0 Then
'obtain rule and write to alt rule column of current row
s2.Cells(rw, col1).Offset(0, ar).Value = s2.Cells(rwcw, w).Value
Match = True
End If
rwcw = rwcw + 1
Loop Until Match = True
End If
End If
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
xwalk = ""
Next col1
End If
count1 = count1 + 1
Loop Until count1 = UBound(TOSes) + 1
Else
For col1 = w To s2.UsedRange.Columns.Count
If Left(s2.Cells(1, col1), 4) = "Rule" Then
If InStr(1, s2.Cells(rw, y), " ") > 0 Then
s1.Cells(rw2, 3) = Trim(Left(s2.Cells(rw, y), 4)) 'sese
Else
s1.Cells(rw2, 3) = s2.Cells(rw, y)
End If
s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
Next col1
End If
ElseIf s2.Cells(rw, y) = "" And Trim(s2.Cells(rw, w)) "" Then
If Len(s2.Cells(rw, 1)) >= 10 Then
text1 = Left(s2.Cells(rw, 1), 10) & " |row: " & rw 'sese
Else
text1 = s2.Cells(rw, 1) & " row: " & rw 'sese
End If
For col1 = w To 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) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
Next col1
End If
Next
For rw3 = 2 To 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"
Next rw3
Dim wb As Workbook
Dim wss, wsSepy, wsSID As Worksheet 'SID = Serivce ID Spreadsheet
Dim sepyRow, sepyCol, acctCol, sidSeseCol, sidAcctCol, j As Long
Dim cell As Range
Dim cellRange As Range
Dim topRow As Range
Dim sepySese As String
MsgBox "All set, make sure there is no #N/A in SESE_RULE column"
End Sub
Below image is the output I got:
问题：如果您看到源数据，我在 A 列中有 SEPY_PFX。我希望每个 SEPY 重复每一行。目前，我的代码给了我 RULE 作为 SEPY_PFX，我仍在努力，但如果有人快速帮助我，我会很高兴，它已经超出了我的能力范围。
此代码将适用于您发布的第一个示例，以提供您想要的输出：
原始来源：
原始结果：
它的工作原理是使用Class and 收藏，一次创建一个条目，然后将其组合在一起以获得结果。
我使用数组来收集和输出数据，因为这样会更快。在你的原作中，你有一些字体颜色，我已经继承了。
您应该能够使其适应您的真实数据，但是，如果您不能，我建议您在某些文件共享网站（例如 DropBox）上发布原始数据的“经过净化的”副本，其中包含正确的列等， OneDrive等；并在此处发布链接，以便我们可以看到“真实的东西”
关于类的使用，请参见奇普·皮尔森的网站 http://www.cpearson.com/Excel/Classes.aspx
另外，请阅读代码中的注释以获取解释和建议。
首先插入一个类模块，重命名它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
对代码中的工作表引用进行更改（只需在常规模块的开头执行此操作）。
首先在您的原始示例上尝试此操作，以便您可以了解它是如何工作的，然后添加额外的列并处理类和集合，或者在此处发回更多详细信息