VBA from wrapped cells to multiple row

[Dampa88]

Dear all,

I'm here again to ask you some inputs.

I created an online form to collect some information from colleagues.
One question allows long text, incluging multiple lines.

When I export to Excel, the multiple lines appear as "wrapped text". Basically, I'd need to convert wrapped text into multiple lines in order to do vlookups and so on.
Additional "Choice" must be copied for these new lines. For this last part I should have no problem, however I'm blocked with the first main step.

Is there any quick code to do this?

In the example below I indicated some possible values for "Free text". What's in common are the new lines. We can have also empty lines (to take out).
Column is A but in the real file is not.


Thanks in advance,
D

From:

Test Forms.xlsx
	A	B
1	Free Text	Choice
2	99968548462541800 99968850854105480	Option A;
3	99489098409840980	Option B;
4	99934534656799567 99978978978956755 100000056482	Option A;Option B;
5	009996854846254180 9999856756756756 100001567568	Option C;
Sheet2

To:

Test Forms.xlsx
	A	B
1	Free Text	Choice
2	99968548462541800	Option A;
3	99968850854105480	Option A;
4	99489098409840980	Option B;
5	99934534656799567	Option A;Option B;
6	99978978978956755	Option A;Option B;
7	100000056482	Option A;Option B;
8	009996854846254180	Option C;
9	9999856756756756	Option C;
10	100001567568	Option C;
Sheett3

 

[Dampa88]

Dear all,

Googling I have understood more about the "carriage return" and then I have been able to solve my problem.

Public Sub separate_line_break()
    target_col = "A"     'Define the column you want to break
    ColLastRow = Range(target_col & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For Each Rng In Range(target_col & "1" & ":" & target_col & ColLastRow)
        If InStr(Rng.Value, vbLf) Then
            Rng.EntireRow.Copy
            Rng.EntireRow.Insert
            Rng.Offset(-1, 0) = Mid(Rng.Value, 1, InStr(Rng.Value, vbLf) - 1)
            Rng.Value = Mid(Rng.Value, Len(Rng.Offset(-1, 0).Value) + 2, Len(Rng.Value))
        End If
    Next
    
    ColLastRow2 = Range(target_col & Rows.Count).End(xlUp).Row
    For Each Rng2 In Range(target_col & "1" & ":" & target_col & ColLastRow2)
        If Len(Rng2) = 0 Then
            Rng2.EntireRow.Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Quote: External link