Split multi-line cell text into multiple cells while maintaining neighboring cell contents for each entry

FierceMouse · Jun 18th 2021

Hello, all! First post for me. And I'm somewhat inexperienced on forums in general.

I had a similar issue to another post on this forum which is why I chose to sign up on OzGrid versus StackOverflow. However, I need some additional assist if possible.

Split Multi line Cell text Into Multiple Rows in range

What I need is for if there is only one line in the cell (ie there is no Chr(10)), for it to still show up in my recreated list.

Code

Private Sub splitcells()

Application.ScreenUpdating = False
 
 Dim LastRow As Long, x As Long, splitList As Variant, i As Long
 
 LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
 For x = LastRow To 2 Step -1
 splitList = Split(Cells(x, 2), Chr(10))
 If UBound(splitList) Then
 For i = UBound(splitList) To 1 Step -1
 Cells(x + 1, 3).Insert Shift:=xlDown
 Cells(x + 1, 4).Insert Shift:=xlDown
 Cells(x + 1, 3) = Cells(x, 1)
 Cells(x + 1, 4) = splitList(i)
 Cells(x, 3) = Cells(x, 1)
 Cells(x, 4) = splitList(0)
 Next i
 End If
 Next x
  
Application.ScreenUpdating = True

End Sub

Display More

Problem:

Also, just for a bonus, so more important to focus on the above, but I also have not used this particular method of moving on the next row before. If the data that needed to be split was in Column "C", how would I tell it to look there within the above script?

Below are some of the other "LastRow" variations I have tried in order to specify what column it looks in rather than just "A". I just wanted to demonstrate that I am attempting/experimenting/researching before just asking someone to solve my problems.

Code

 'Range("C1").Select
 'LastRow = Cells.Find("*", After:=ActiveCell, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 

 'Set LastRow01 = Cells.Find("*", After:=Sheet1.Cells(1, 3), SearchOrder:=xlByRows, SearchDirection:=xlPrevious) '.Row
 'On Error GoTo 0
 'If Not LastRow01 Is Nothing Then Application.Goto LastRow01, True
  

 'Columns("C:D").Select
 'LastRow = Selection.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 

 'Dim LastRow As Range
 'LastRow = Range("C1:D50").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 

 'LastRow = ActiveSheet.Columns("C:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Display More

Thank you, thank you, for any and all support.

-Mouse

**royUK** · Jun 18th 2021

Attach an example workbook

FierceMouse · Jun 18th 2021

I'm sorry. Here's the workbook I took the screenshot from: Split Test.xlsx

**KjBox** · Jun 18th 2021

Are the colours just for clarity of your explanation, or do you need the desired result to be coloured?

FierceMouse · Jun 18th 2021

Just for clarity. Color is not needed. Primarily just need that blank entry in the result from where there was only one line in the original data to not be blank.

Thank you,

Mouse

**KjBox** · Jun 18th 2021

Try this

Code

Sub SplitData()
    Dim x, y, z, i As Long, ii As Long, iii As Long, iv As Long
    
    Const lCol As Long = 2  'Change to suit the column immediately before the column
                            'that holds the data to be split (Column A = 1, B = 2 etc.)
    
    With Sheets("Sheet1").Cells(1).CurrentRegion    'Change sheet name as required
        x = .Value
        ReDim z(1 To UBound(x, 2), 1 To 1)
        For i = 1 To UBound(x, 1)
            y = Split(x(i, lCol + 1), vbLf)
            If IsArray(y) Then
                For ii = LBound(y) To UBound(y)
                    iii = iii + 1: ReDim Preserve z(1 To UBound(x, 2), 1 To iii)
                    For iv = 1 To UBound(x, 2)
                        If iv = lCol Then
                            z(lCol, iii) = x(i, lCol)
                            z(lCol + 1, iii) = Right(y(ii), Len(y(ii)) - 1)
                            iv = iv + 1
                        Else
                            z(iv, iii) = x(i, iv)
                        End If
                    Next
                Next
            Else
                iii = iii + 1: ReDim Preserve z(1 To UBound(x, 2), 1 To iii)
                    For iv = 1 To UBound(x, 2)
                        If iv = lCol Then
                            z(lCol, iii) = x(i, lCol)
                            z(lCol + 1, iii) = Right(y(ii), Len(y) - 1)
                            iv = iv + 1
                        Else
                            z(iv, iii) = x(i, iv)
                        End If
                    Next
                z(lCol, iii) = x(i, lCol)
                z(lCol + 1, iii) = Right(y, Len(y) - 1)
            End If
        Next
        .Resize(UBound(z, 2), UBound(z, 1)) = Application.Transpose(z)
        With .Parent.UsedRange.Columns(lCol + 1)
            .HorizontalAlignment = -4108
            .Rows.AutoFit
        End With
    End With
        
End Sub

Display More

I have shown where in the code you can change it to suit the column immediately prior to the column with the multi line data

FierceMouse · Jun 19th 2021

I very much appreciate the time invested and creativity in problem solving. There seems to be a miscommunication as to what is my end goal. I apologize.

Notably, this code chops the first character off of the data. I did not request this in my post either in word or image, though I notice that my uploaded workbook does show this as the desired difference. I had added those letters to the workbook for ease of identifying what moved where while I was working and neglected to notice that I had saved that change before uploading when prompted.

It also removes the header and tampers with columns outside of A and B (or whichever ones that will be used in my larger workbook). If I need to do this process in another sheet and call it from there to avoid this, that's ok. Just a bonus if it can be all in one place with my other data.

It looks like it will accept cells with even more lines than were in the example so that's stellar. Some of the user entries could be dozens of lines.

I also need to have it preserve the original data and put the new list in an assigned column similar to my original code.

Here is a more simplistic presentation of what my goal is. Colors and borders do not need to be preserved and are again there for clarity in presenting the idea of original data and desired positioning.

I'll work through the code you provided some more, but request a little more assist.

Here's the updated workbook: Split Test.xlsm

Thank you!

**KjBox** · Jun 19th 2021

The file you attached is the original file not the updated one

FierceMouse · Jun 19th 2021

There are multiple sheets in the above .xlsm whereas the original .xlsx just had the one.

The most recent example is titled "Sheet1" for ease. The desired results are shown on sheet "End Goal". The original example is the third sheet.

I have uploaded the .xlsm again with the first sheet activated and with a new title so to not be mistaken with either of the above files that would've been better practice for me to have donein the first place.

Split Test FierceMouse.xlsm

Thank you again for your patience.

Mouse

**KjBox** · Jun 19th 2021

OK my mistake re the multiple sheets.

Try the attached file. I have added a button, click it to run the code.

Note that the new code is in a Standard Module, the ThisWorkbook Object Module should only contain Workbook Event code.

Code assigned to the button is:

Code

Option Explicit

Sub SplitData()
    Dim x, y, z, i As Long, ii As Long, iii As Long
    
    Const lCol As Long = 2  'Change to suit the column immediately before the column
                            'that holds the data to be split (Column A = 1, B = 2 etc.)
    
    With Sheets("Sheet1").Cells(1).CurrentRegion    'Change sheet name as required
        x = .Value
        ReDim z(1 To 2, 1 To 1)
        For i = 2 To UBound(x, 1)
            y = Split(x(i, lCol + 1), vbLf)
            If IsArray(y) Then
                For ii = LBound(y) To UBound(y)
                    If y(ii) <> "" Then
                        iii = iii + 1: ReDim Preserve z(1 To 2, 1 To iii)
                        z(LBound(z, 2), iii) = x(i, lCol)
                        z(LBound(z, 2) + 1, iii) = y(ii)
                    End If
                Next
            Else
                iii = iii + 1: ReDim Preserve z(1 To UBound(x, 2), 1 To iii)
                z(UBound(z, 2), iii) = x(i, lCol)
                z(UBound(z, 2) + 1, iii) = y
            End If
        Next
        .Parent.UsedRange.Offset(1).Columns(lCol + 2).Resize(, 2).ClearContents
        .Parent.Cells(2, lCol + 2).Resize(UBound(z, 2), 2) = Application.Transpose(z)
    End With
        
End Sub

Display More

Change the code where indicated to suit your actual workbook.

In this example Column B is the column immediately prior to the column that has the multiline data hence the variable lCol is given a value of 2, and the sheet name is "Sheet1".

FierceMouse · Jun 20th 2021

This is actually how it would reflect in my greater workbook. The two empty columns will already be there, ready for the split lines to be there. If columns were to be inserted it would change references to data to the right and I'd like to prevent that. They will not necessarily be right next to it, I would like to be able to specify.

Sheet1 is the original data, all columns constant, the empty columns will be there, and all of it will be more or less nested between data that I do not want shifted up/down/left/right. If it takes multiple steps, it doesn't really matter to me how many columns are in there, just so that

The "End Goal" sheet is identical to "Sheet1", just with the data manually put there how I would like the code to put it there.

Here it is as requested, the only major difference is that I put other columns in there to signify that the original data and the resulting data will not be neighboring columns: Split Test Example Extended.xlsm

Here is my bigger workbook: Carbaryl Search Terms Snip.xlsm. It is full of bugs and other potentially distracting problems/details that I will will get to at a later date, but then you can see the more or less the full context. In this workbook, the data with multiple lines is in column "S". The destination column for the split data is "W". The tag that is repeated for each line is in "R" to be in "V". This code will be in the sub "RelChemsSubmitButton".

Again, thank you for all you insight on this project.

-Mouse

**KjBox** · Jun 20th 2021

Thanks for your actual workbook example, always easier to work with a realistic example.

The VBA is password protected, what is the password? you can PM it to me if you prefer.

FierceMouse · Jun 20th 2021

Oh. I could've sworn I took that off. I'm glad you mentioned, because apparently I took it off my other workbook I had open.

Here's an unlocked version: Carbaryl Search Terms Snip Unlocked.xlsm

FierceMouse · Jun 20th 2021

And, oh man, the "Split Test FierceMouse with code.xlsm" is awesome. I will have to play tomorrow though and blend it in to my other workbook. It's 830pm here and still have to walk the dog and read to kiddo.

Thank you so much for all your help. TTYS. I'll touch base in the morning.

**KjBox** · Jun 20th 2021

Here is your actual file sample with the modified SplitData code and a button to run it.

You worksheet said "All Terms, Split, Cleaned" so I included code to trim and clean all spilt lines.

Modified code:

Code

Option Explicit

Sub SplitData()
    Dim x, y, z, i As Long, ii As Long, iii As Long, lRow As Long
    
    Const lSplitCol As Long = 19    ' column with multiline data
    Const lResCol As Long = 22      ' column where result starts
    
    With Sheet10
        lRow = .Cells(.Rows.Count, lSplitCol).End(xlUp).Row - 3
        x = .Cells(4, lSplitCol - 1).Resize(lRow, 2)
        ReDim z(1 To 2, 1 To 1)
        For i = 1 To UBound(x, 1)
            y = Split(x(i, 2), vbLf)
            If IsArray(y) Then
                For ii = LBound(y) To UBound(y)
                    If y(ii) <> "" Then
                        iii = iii + 1: ReDim Preserve z(1 To 2, 1 To iii)
                        z(LBound(z, 2), iii) = x(i, 1)
                        z(LBound(z, 2) + 1, iii) = Application.Clean(Trim(y(ii)))
                    End If
                Next
            Else
                iii = iii + 1: ReDim Preserve z(1 To UBound(x, 2), 1 To iii)
                z(UBound(z, 2), iii) = x(i, 1)
                z(UBound(z, 2) + 1, iii) = Application.Clean(Trim(y))
            End If
        Next
        Application.ScreenUpdating = 0
        lRow = .Cells(.Rows.Count, lResCol).End(xlUp).Row
        With .Cells(4, lResCol)
            .Resize(lRow, 2).ClearContents
            .Resize(UBound(z, 2), 2) = Application.Transpose(z)
            .Resize(UBound(z, 2), 2).HorizontalAlignment = -4131
        End With
        .Columns(lResCol + 1).AutoFit
    End With
        
End Sub

Display More

FierceMouse · Jun 20th 2021

Luar biasa! Terima kasih! Oh, how much I appreciate you.

**KjBox** · Jun 20th 2021

You're welcome, and thank you for the Likes.

FierceMouse · Aug 12th 2021

Hey, KjBox. I was trying to change this up a touch in order for it to maintain the previous three columns vs the previous one.

These are the changes I've made so far in this workbook: Search Terms Tool.xlsm, thinking I could reverse engineer your code and understand how the array is being manipulated, but I think that doing it this way is messing with the 4th column too many times. And of course the adjustments I made cause bugs. I imagine there is a simple line that lets me preserve the three cells to the left rather than preserving row after row and trying to overlay them.

Code

 lRow = .Cells(.Rows.Count, lSplitCol).End(xlUp).Row - 3 'AP4, Synonyms
 ''' X = .Cells(4, lSplitCol - 1).Resize(lRow, 2) 'one column to left, untouched original code
' XAO = .Cells(4, lSplitCol - 1).Resize(lRow, 2) 'one column to left, AO4, Approved Chem
' XAN = .Cells(4, lSplitCol - 2).Resize(lRow, 2) 'two columns to left, AN4, Source
 XAM = .Cells(4, lSplitCol - 3).Resize(lRow, 4) 'three columns to left, AM4, URL

 '''ReDim z(1 To 2, 1 To 1)
 ReDim zAO(1 To 2, 1 To 4)
 ReDim zAN(1 To 2, 1 To 4)
 ReDim zAM(1 To 2, 1 To 4)
 
 '''For i = 1 To UBound(X, 1)
 For i = 1 To UBound(XAM, 1) 'rows in array
 '''y = Split(X(i, 2), vbLf)
    y = Split(XAM(i, 4), vbLf) 'split array at carriage return
 
 If IsArray(y) Then
    For ii = LBound(y) To UBound(y) 'rows after split
        If y(ii) <> "" Then
            '''iii = iii + 1: ReDim Preserve z(1 To 2, 1 To iii)
            iiiAO = iiiAO + 1: ReDim Preserve zAO(1 To 2, 1 To iiiAO)
            iiiAN = iiiAN + 1: ReDim Preserve zAN(1 To 2, 1 To iiiAN)
            iiiAM = iiiAM + 1: ReDim Preserve zAM(1 To 2, 1 To iiiAM)

            '''z(LBound(z, 2), iii) = XAM(i, 1)
            zAO(LBound(zAO, 4), iiiAO) = XAM(i, 1)
            zAN(LBound(zAN, 4), iiiAN) = XAM(i, 2)
            zAM(LBound(zAM, 4), iiiAM) = XAM(i, 3)
                      
            '''z(LBound(z, 2) + 1, iii) = Application.Clean(Trim(y(ii)))
            zAO(LBound(zAO, 4) + 1, iiiAO) = Application.Clean(Trim(y(ii)))
            zAN(LBound(zAN, 4) + 1, iiiAN) = Application.Clean(Trim(y(ii)))
            zAM(LBound(zAM, 4) + 1, iiiAM) = Application.Clean(Trim(y(ii)))

            End If
    Next
 Else
    '''iii = iii + 1: ReDim Preserve z(1 To UBound(X, 2), 1 To iii)
    iii = iii + 1: ReDim Preserve z(1 To UBound(XAM, 4), 1 To iii)
    '''z(UBound(z, 2), iii) = XAM(i, 1)
    z(UBound(z, 4), iii) = XAM(i, 1)
    '''z(UBound(z, 2) + 1, iii) = Application.Clean(Trim(y))
    z(UBound(z, 4) + 1, iii) = Application.Clean(Trim(y))
    End If
 
 Next
 Application.ScreenUpdating = 0
 lRow = .Cells(.Rows.Count, lResCol).End(xlUp).Row
 With .Cells(4, lResCol)
 '''.Resize(lRow, 2).ClearContents
 .Resize(lRow, 4).ClearContents
 '''.Resize(UBound(z, 2), 2) = Application.Transpose(z)
 .Resize(UBound(zAO, 2), 4) = Application.Transpose(zAO)
 '''.Resize(UBound(z, 2), 2).HorizontalAlignment = -4131
 End With
 .Columns(lResCol + 1).AutoFit

Display More

I had gotten it to behave at one point though not preserve correctly.

This is what would be stellar. No color, borders, or dimensions, etc. need to be preserved.

Thanks!

FierceMouse · Aug 13th 2021

I think I may have come up with a remedial workaround. I TextJoined the 3 columns to the left, did your code, and then split the column I textJoined.

Split multi-line cell text into multiple cells while maintaining neighboring cell contents for each entry

Participate now!

Share

Users Viewing This Thread