vba VBA将excel单元格中的多行文本拆分为单独的行并保留相邻的单元格值
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/25776914/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA to split multi-line text in a excel cell into separate rows and keeping adjacent cell values
提问by Chito
Please see the attach image which shows my data and expected data after running the macro,
请参阅显示我的数据和运行宏后预期数据的附加图像,
- I would like to split the multi line cell in column B and listed in separate rows and removed text from first space. This values will be called as SESE_ID and should have the RULE from column C for each SESE_ID from the same row.
- If there is more than one prefix in column A separated by a comma or space-comma, then repeat the above values for each prefix.
- 我想拆分 B 列中的多行单元格并在单独的行中列出并从第一个空格中删除文本。该值将被称为 SESE_ID,并且对于来自同一行的每个 SESE_ID 应该具有来自 C 列的规则。
- 如果 A 列中有多个前缀由逗号或空格逗号分隔,则对每个前缀重复上述值。
Please someone help me in the macro...
请有人帮助我在宏...
- Attached 1st image is the sample source:
- 附加的第一张图片是示例源:
- And following is the macro:
- 以下是宏:
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:
Problem: If you see the source data, I have SEPY_PFX in column A. I wanted every row to be repeated for each SEPY. Currently my code gave me RULE as SEPY_PFX, I am still working on it BUT it will be glad if someone help me on this quickly, it is already going above my head.
下图是我得到的输出:
问题:如果您看到源数据,我在 A 列中有 SEPY_PFX。我希望每个 SEPY 的每一行都重复。目前我的代码给了我 RULE 作为 SEPY_PFX,我仍在研究它,但如果有人快速帮助我,我会很高兴,它已经超出了我的头脑。
回答by Ron Rosenfeld
This code will work on the first example you posted to give the output you wanted:
此代码将适用于您发布的第一个示例,以提供您想要的输出:
Original Source:
原始来源:
Original Results:
原始结果:
It works by using Classand Collections, creating each entry one at a time, and then putting it together for the results.
它的工作原理是使用Class和Collections,一次创建一个条目,然后将它们放在一起以获得结果。
I use arrays to collect and output the data, because this will work much faster. In your original you had some font coloring, which I have carried over.
我使用数组来收集和输出数据,因为这会工作得更快。在你的原件中,你有一些字体着色,我已经继承了。
You should be able to adapt it to your real data, but, if you cannot, I suggest you post a "sanitized" copy of your original data, with the correct columns and so forth, on some file sharing web site such as DropBox, OneDrive, etc; and post a link here so we can see the "real stuff"
您应该能够使其适应您的真实数据,但是,如果您不能,我建议您在某些文件共享网站(例如 DropBox)上发布原始数据的“清理”副本,其中包含正确的列等, OneDrive等;并在此处发布链接,以便我们可以看到“真实的东西”
With regard to the use of classes, please see Chip Pearson's web site
关于类的使用,请看 Chip Pearson的网站
Also, please read the comments in the code for explanations and suggestions.
另外,请阅读代码中的注释以获取解释和建议。
First insert a Class Module, ReNAME it cOfcCodeand paste the code below into it:
首先插入一个类模块,将其重命名为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
Then, in a regular module:
然后,在常规模块中:
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
Make the changes to the Worksheet references in the code (only need to do that at the beginning of the regular module.
对代码中的 Worksheet 引用进行更改(只需在常规模块的开头执行此操作。
Try this first on your original example, so you can see how it works, then add in the extra columns and processing to the Class and the Collection, or post back here with more details
首先在您的原始示例上尝试此操作,以便您可以查看它是如何工作的,然后将额外的列添加到类和集合中并进行处理,或者在此处发布更多详细信息
回答by Fumu 7
I assume the original data is in worksheet "DATA", and worksheet "Expected Output" which is used to store processed data , exist already.
我假设原始数据在工作表“DATA”中,用于存储处理数据的工作表“预期输出”已经存在。
Your code will be: Operation of most lines are explained by comments (right of "'")
您的代码将是:大多数行的操作由注释解释(“'”的右侧)
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