Separating details nested in a single column to multiple columns

[hanahass]

Hi Masters!

I'm in dire need of your help!

I have a messy file filled with data that I need to clean up. The data is roughly like this :

sample.xlsx
	A	B	C
1	Code	Name	Details
2	AA1	Person 1 Person 2 Person 3	Person 1 Address Person 1 Phone Person 1 Email Person 2 Address Person 2 Phone Person 2 Email Person 3 Address Person 3 Phone Person 3 Email
3	AA2	Person 4 Person 5	Person 4 Address Person 4 Phone Person 4 Email Person 5 Address Person 5 Phone Person 5 Email
4	AA3	Person 6, Person 7	Person 6 Address Person 6 Phone Person 6 Email Person 7 Address Person 7 Phone Person 7 Email
Sheet1

And I need the end product to be like this :

Code	Name	Address	Phone	Email
AA1	Person 1	Person 1 Address	Person 1 Phone	Person 1 Email
AA1	Person 2	Person 2 Address	Person 2 Phone	Person 2 Email
AA1	Person 3	Person 3 Address	Person 3 Phone	Person 3 Email
AA2	Person 4	Person 4 Address	Person 4 Phone	Person 4 Email
AA2	Person 5	Person 5 Address	Person 5 Phone	Person 5 Email
AA3	Person 6	Person 6 Address	Person 6 Phone	Person 6 Email
AA3	Person 7	Person 7 Address	Person 7 Phone	Person 7 Email

So that I could start washing the data.

Most of the data would be as per Row 1 and 2 where they are separated by Enter in the same cell. So if you could help me with that alone, that would be more than great!
Also, the characteristic of the Name in Column B is that they are 10-digit codes.

Please let me know if there's any info you need!

Thanks in advance! I really appreciate your help!

 

[maabadi]

If your Dat at Sheet1 and You want to See Result at Sheet2 Try this:

Sub SortData()
Dim i As Long, P As Long, Lr1 As Long, C As Long, A As Long, B As Long, F As Long, E As Long
Dim j As Long, S As Long, d As Long, Z As String, Lr2 As Long, K As Long, L As Long, M As Long, R As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
On Error Resume Next
With Sh1
Lr1 = .Range("B" & Rows.Count).End(xlUp).Row

Lr2 = Sh2.Range("B" & Rows.Count).End(xlUp).Row
d = Lr2 + 1
For i = 2 To Lr1
.Range("B" & i).Value = Replace(.Range("B" & i).Value, ",", vbLf)
C = Len(.Range("B" & i)) - Len(Replace(.Range("B" & i), vbLf, "")) + 1
Sh2.Range("A" & d & ":A" & d + C - 1).Value = .Range("A" & i).Value
S = 0
M = 0
For j = 1 To C
P = InStr(S + 1, .Range("B2").Value, vbLf)
Sh2.Range("B" & d).Value = Trim(Mid(.Range("B" & i), S + 1, P - S))
For K = 1 To 3
L = InStr(M + 1, .Range("C2").Value, vbLf)
If L = 0 And M < Len(.Range("C2").Value) Then L = Len(.Range("C2").Value)
Sh2.Cells(d, 2 + K).Value = Trim(Mid(.Range("C" & i), M + 1, L - M))
M = L
Next K
S = P
d = d + 1
If S = Len(.Range("B2").Value) Then Exit For
Next j

Next i
End With
End Sub

 

[hanahass]

Hi maabadi! thank you for your reply!

sadly the data is all jumbled up after i ran the vba.

perhaps can you help to just break and label Column B and into the below?

Code	Name
AA1	Person 1
AA1	Person 2
AA1	Person 3
AA2	Person 4
AA2	Person 5
AA3	Person 6
AA3	Person 7

Thank you so much!

 

[maabadi]

For me Working Correct.
Please Upload Sample Data to We Know how you separated data at each line.
at Xl2BB Add-in I Test VBLF works, maybe at your file is different character.
you can upload it at free hosting site e.g. GoogleDrive, OneDrive, www.Dropbox.com and Insert link here.

 

[hanahass]

i couldn't upload any sample data because the data is confidential. sorry!

 

[maabadi]

We don't want your real data, we want example with fake data that we know what is exact structure of it.

 

[maabadi]

I upload for you one example data and result after this modified code here.
Source file

Book1.xlsx
	A	B	C	D
1	Code	Name	Details
2	AA1	Michael Sara Beatris	DisneyLand, Street 21, No. 158 0076-598-456-73-865 Michael65@yahoo.com ParadiseCity, BLv. 456, No. 387 0045-398-762-64-832 SaraK56@gmail.com Tok21Kirin, Doroty Way, No. 478 0095-821-741-99-145 Beat88@yahoo.com
3	AA2	Will John	SandbadCity, GLD. Company, BSC Unit 0015-785-684-75-362 Will76@gld.nc DIvidorLand, Cokry Ins., FED Section 088-654-987-32-14 John81@Ckr.in
4	AA3	KenDall, Kathrin	ExampleCity, Sample St., No. 777 0066-951-753-68-42 Kendall65@nakin.kn LuckyWorld, Street 87, No. 445 0099-999-999-99-99 Kathrin77@Lucky.lu
5
Sheet1

VBA Code:

Sub SortData()
Dim i As Long, P As Long, Lr1 As Long, C As Long, A As Long, B As Long, F As Long, E As Long
Dim j As Long, S As Long, d As Long, Lr2 As Long, K As Long, L As Long, M As Long, R As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet, X As String, Y As String
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
On Error Resume Next
With Sh1
Lr1 = .Range("B" & Rows.Count).End(xlUp).Row
Lr2 = Sh2.Range("B" & Rows.Count).End(xlUp).Row
If Lr2 = 1 Then
Range("A1").Value = "Code"
Range("B1").Value = "Name"
Range("C1").Value = "Address"
Range("D1").Value = "Phone"
Range("E1").Value = "Email"
End If
d = Lr2 + 1
For i = 2 To Lr1
X = Replace(.Range("B" & i).Value, ",", vbLf)
C = Len(X) - Len(Replace(X, vbLf, "")) + 1
Sh2.Range("A" & d & ":A" & d + C - 1).Value = .Range("A" & i).Value
S = 0
M = 0
For j = 1 To C
P = InStr(S + 1, X, vbLf)
If P = 0 Then P = Len(X)
Sh2.Range("B" & d).Value = Trim(Mid(X, S + 1, P - S))
For K = 1 To 3
Y = .Range("C" & i).Value
L = InStr(M + 1, Y, vbLf)
If L = 0 And M < Len(Y) Then L = Len(Y)
Sh2.Cells(d, 2 + K).Value = Trim(Mid(Y, M + 1, L - M))
M = L
Next K
S = P
d = d + 1
If S = Len(X) Then Exit For
Next j

Next i
End With
End Sub

Result at Sheet2:

Book1.xlsx
	A	B	C	D	E	F
1	Code	Name	Address	Phone	Email
2	AA1	Michael	DisneyLand, Street 21, No. 158	0076-598-456-73-865	Michael65@yahoo.com
3	AA1	Sara	ParadiseCity, BLv. 456, No. 387	0045-398-762-64-832	SaraK56@gmail.com
4	AA1	Beatris	Tok21Kirin, Doroty Way, No. 478	0095-821-741-99-145	Beat88@yahoo.com
5	AA2	Will	SandbadCity, GLD. Company, BSC Unit	0015-785-684-75-362	Will76@gld.nc
6	AA2	John	DIvidorLand, Cokry Ins., FED Section	088-654-987-32-14	John81@Ckr.in
7	AA3	KenDall	ExampleCity, Sample St., No. 777	0066-951-753-68-42	Kendall65@nakin.kn
8	AA3	Kathrin	LuckyWorld, Street 87, No. 445	0099-999-999-99-99	Kathrin77@Lucky.lu
9
Sheet2

 

[hanahass]

I am literally crying right now! Thank you so much!

Some of the data is still scrambled up because of my original file. But this has helped sooooo much!

THANK YOU! God bless you!

 

[Peter_SSs]

Just a suggestion

Range("A1").Value = "Code"
Range("B1").Value = "Name"
Range("C1").Value = "Address"
Range("D1").Value = "Phone"
Range("E1").Value = "Email"
Range("A1:E1") = Array("Code", "Name", "Address", "Phone", "Email")