Excel many items in one field

rjef
rjef used Ask the Experts™
on
i have a spread sheet with many items in one cell

         column a            column b
row1 part1                    serial1
                                      serial 2
                                      serial 3
                                      serial 4
row2  part2                  serial 5
                                     serial 6
how can i break it down into separate rows for each serial with the part1 in each row?
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Author

Commented:
see attachment
example.pptx
Top Expert 2015

Commented:
I believe this is what you are looking for..Check Column-C for the formula..its different in C1 and then rest of the cells..

Saurabh...
Parts.xlsx

Author

Commented:
i have attached an example
Report-many-lines.xlsx
OWASP: Avoiding Hacker Tricks

Learn to build secure applications from the mindset of the hacker and avoid being exploited.

Top Expert 2015

Commented:
Their you this is what you are looking for.. Code for your reference..and check sheet-2 column D&E

Sub breakmydata()
    Dim lrow As Long
    Dim cell As Range, rng As Range
    Dim i As Long, str As String
    Dim k As Long

    lrow = Cells(Cells.Rows.Count, "a").End(xlUp).Row

    Set rng = Range("A2:A" & lrow)
    k = 2
    For Each cell In rng


        For i = 1 To Len(cell.Offset(0, 1).Value)
            Cells(k, "D").Value = cell.Value

            If Asc(Mid(cell.Offset(0, 1).Value, i, 1)) = 13 Or i = Len(cell.Offset(0, 1).Value) Then
                Cells(k, "e").NumberFormat = "@"
                If i = Len(cell.Offset(0, 1).Value) Then
              Cells(k, "e").Value = str & Mid(cell.Offset(0, 1).Value, i, 1)
                Else
                   Cells(k, "e").Value = str
                End If
                
                k = k + 1
                str = ""
            Else
                If str = "" Then
                    str = Mid(cell.Offset(0, 1).Value, i, 1)
                Else
                    str = str & Mid(cell.Offset(0, 1).Value, i, 1)
                End If

            End If

        Next i
    Next cell
End Sub

Open in new window


Saurabh....
Report-many-lines.xlsm
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
Or you may try this also....
To test the code, click the button "Click Here" to get the desired output.

Sub ReArrangeData()
Dim lr As Long, i As Long, r As Long
Dim rng As Range, cell As Range
Dim str() As String

Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
r = 2
For Each cell In rng
    If InStr(cell.Offset(0, 1), Chr(10)) > 0 Then
        str = Split(cell.Offset(0, 1), Chr(10))
        For i = 0 To UBound(str)
            Range("D" & r).Value = cell
            Range("E" & r).NumberFormat = "@"
            Range("E" & r).Value = str(i)
            r = r + 1
        Next i
    Else
        Range("D" & r).Value = cell
        Range("E" & r).Value = cell.Offset(0, 1)
    End If
Next cell
    
Application.ScreenUpdating = True
MsgBox "Finished.", vbInformation
End Sub

Open in new window

Report-many-lines.xlsm

Author

Commented:
sktneer
there appears to be another character in front of the serial number on some of the results.
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
Okay see the attached now.
Report-many-lines.xlsm
Top Expert 2015

Commented:
rjef,

Did you run my code?? What is your finding on the same??

Saurabh...

Author

Commented:
Saurabh Singh Teotia
Actually your code was the one with the extra character on some of the results.  

sktneer
i will check your code in the morning
Top Expert 2015

Commented:
rjef,

When you mean extra characters? Can you help me understand what you mean by that I can resolve that quickly if i understand what you are referring to?

Saurabh..

Author

Commented:
Saurabh Singh Teotia
here are your results .  see the lengths
results-Saurabh-Singh-Teotia.xlsx
Top Expert 2015

Commented:
Rjef,

Use this code...

Sub breakmydata()
    Dim lrow As Long
    Dim cell As Range, rng As Range
    Dim i As Long, str As String
    Dim k As Long

    lrow = Cells(Cells.Rows.Count, "a").End(xlUp).Row

    Set rng = Range("A2:A" & lrow)
    k = 2
    For Each cell In rng


        For i = 1 To Len(cell.Offset(0, 1).Value)
            Cells(k, "D").Value = cell.Value

            If Asc(Mid(cell.Offset(0, 1).Value, i, 1)) = 13 Or i = Len(cell.Offset(0, 1).Value) Then
                Cells(k, "e").NumberFormat = "@"
                If i = Len(cell.Offset(0, 1).Value) Then
              Cells(k, "e").Value = str & Mid(cell.Offset(0, 1).Value, i, 1)
                Else
                   Cells(k, "e").Value = Trim(Replace(str, Chr(10), ""))
                End If
                
                k = k + 1
                str = ""
            Else
                If str = "" Then
                    str = Mid(cell.Offset(0, 1).Value, i, 1)
                Else
                    str = str & Mid(cell.Offset(0, 1).Value, i, 1)
                End If

            End If

        Next i
    Next cell
End Sub

Open in new window

Author

Commented:
sktneer
yours worked perefectly.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial