VBA将excel单元格中的多行文本拆分为单独的行并保持相邻的单元格值
请参阅附加图像，该图像显示运行宏后的数据和预期数据
- 我想在B列中拆分多行单元格并在单独的行中列出，并从第一个空格中删除文本。此值将被称为SESE_ID，并且应该具有来自同一行的每个SESE_ID的C列的RULE。
- 如果A列中有多个前缀，以逗号或空格 - 逗号分隔，则对每个前缀重复上述值。
请有人在宏观中帮助我......
- 附加的第一张图片是样本来源：
- 以下是宏：
-
下图是我得到的输出：
-
问题：如果您看到源数据，我在A列中有SEPY_PFX。我希望每个SEPY重复每一行。目前我的代码给了我作为SEPY_PFX的RULE，我仍然在努力但是如果有人帮助我这么快就会很高兴，它已经超出了我的想法。
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
2 个答案:
答案 0 :(得分：4)
此代码适用于您发布的第一个示例，用于提供您想要的输出：
原始来源：
原始结果：
它的工作原理是使用类和集合，一次创建一个条目，然后将它们放在一起以获得结果。
我使用数组来收集和输出数据，因为这样可以更快地工作。在你的原版中你有一些字体着色，我已经把它带走了。
您应该能够根据您的实际数据进行调整，但是，如果您不能，我建议您发布一个＆＃34;已消毒的＆＃34;在一些文件共享网站（如DropBox，OneDrive等）上复制原始数据，使用正确的列等等;并在此处发布链接，以便我们可以看到＆＃34;真实内容＆＃34;
关于课程的使用，请参阅Chip Pearson's web site
另外，请阅读代码中的注释以获得解释和建议。
首先插入一个类模块，重新命名 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引用进行更改（只需要在常规模块的开头执行此操作。
首先在原始示例中尝试此操作，以便您可以看到它的工作原理，然后添加额外的列并处理到类和集合，或者在此处发布更多详细信息
答案 1 :(得分：0)
我假设原始数据在工作表“DATA”中，并且已经存在用于存储已处理数据的工作表“预期输出”。
您的代码将是：大多数行的操作由注释（“'”右侧）
解释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
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？