VBA to split multiline text in excel cell into separate lines and keep adjacent cell values
See attached image which shows my data and expected data after running the macro,
- I would like to split a multi-line row cell in column B and specify in separate lines and remove the text from the first space. These values will be named SESE_ID and must have a RULE from column C for every SESE_ID from the same row.
- If column A contains more than one comma or comma separated prefix, repeat the above values for each prefix.
Please help me in the macro ...
- The attached 1st image is a sample source:
- And here 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 is the result I got:
-
Problem: If you see the original data, I have SEPY_PFX in column A. I wanted every row to repeat for every SEPY. Currently my code gave me RULE as SEPY_PFX, I am still working on it, but he would be glad if someone can help me with this quickly, it is already going above my head.
-1
source to share
2 answers
This code will work in the first example you posted to provide the desired output:
Original source:
Original results:
It works with Class and Collection , creating each record one at a time and then adding it up for results.
I am using arrays to collect and output data because it will run much faster. In your original, you had a font coloration that I transferred.
You should be able to adapt it to your actual data, but if you cannot, I suggest you post a "sanitized" copy of your original data with the correct columns, etc. on some file sharing website like DropBox, OneDrive, etc .; and post the link here so we can see the "real stuff"
As for using the classes, see the Chip Pearson website
Also, read the comments in the code for explanations and suggestions.
First, insert the class module, rename it cOfcCode and paste the code below into it:
'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 changes to the references to the worksheet in the code (you only need to do this at the beginning of the normal module.
Try it first in your original example so you can see how it works, then add additional columns and process them into class and collection, or post more details here
+3
source to share
I am assuming the original data is on the "DATA" sheet and the "Expected Result" worksheet that is used to store the processed data already exists.
Your code will be: Most of the lines are explained by comments (to the right of the "'")
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
0
source to share