Reformatting Data from 1:Many to 1:1

[juxel]

I'm losing my mind on something that I feel should be quite easy.

I'm trying to convert data from 1:Many, such as the attached sample image. For example, lets say I have data like this:

Person	Item
Bob	Bananas, Apples
Carl	Oranges, Kiwi, Chocolate

<tbody>
</tbody>

https://imgur.com/a/M2JCJ (sample, 1:Many)

I want to convert this to a 1:1 relationship like:

Person	Item
Bob	Bananas
Bob	Apples
Carl	Oranges
Carl	Kiwi
Carl	Chocolate

<tbody>
</tbody>

https://imgur.com/a/Qsmfb (desired result)

I've split the data on the commas, but I cannot figure out how to loop through and create the 1:1 relationship. The items field pre-split will have between 1 and 12 items for each "Person"

Thank you very much!

 

[Joe4]

Here is a macro that should do that for you (assuming that data is in columns A and B and header is row 1 and data starts on row 2):

Sub MyTransposeMacro()

    Dim lastRow As Long
    Dim myRow As Long
    Dim numCols As Long
    
    Application.ScreenUpdating = False
    
'   Find last cell in column A with data
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Split columns B into multiple columns
    Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, TrailingMinusNumbers:=True

'   Loop through all rows starting at end, up to row 2
    For myRow = lastRow To 2 Step -1
'       Count number of columns with data
        numCols = Cells(myRow, Columns.Count).End(xlToLeft).Row - 1
'       If more than one item, transpose
        If numCols > 1 Then
'           Insert blank row
            Range(Cells(myRow + 1, "A"), Cells(myRow + numCols, "A")).EntireRow.Insert
'           Copy/tranpose value
            Range(Cells(myRow, "B"), Cells(myRow, numCols + 1)).Copy
            Cells(myRow + 1, "B").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
'           Copy value from column A down
            Range(Cells(myRow + 1, "A"), Cells(myRow + numCols, "A")) = Cells(myRow, "A")
'           Delete original row
            Rows(myRow).Delete
        End If
    Next myRow
    
    Application.ScreenUpdating = True

End Sub

 

[juxel]

Joe, Thanks for the very quick reply.

I don't know if I did something wrong, but this didn't quite work for me. It got very close, but the first row and last row of the original data is not behaving correctly when I run the macro. See attached workbook.

https://www.icloud.com/iclouddrive/0-qY2GU_VYhwj2SSR1fagkVaw#Test_Sheet.xlsm

Apparently I don't have permission to attach it through the forum system, so I used a third party site. My posting permissions say:

• You may not post attachments

 

[Joe4]

No one can upload files to this site. But there are tools you can use to post screen images. They are listed in Section B of this link here: http://www.mrexcel.com/forum/board-a...forum-use.html.

Also, there is a Test Here forum on this board that you can use to test out these tools to make sure they are working correctly before using them in your question.

 

[Rick Rothstein]

Here is another macro for you to consider (I have no idea whether it will experience the same problem you are having with Joe's code or not)...

[table="width: 500"]
[tr]
	[td]Sub ManyToOne()
  Dim R As Long, X As Long, Z As Long, LastRow As Long, Data As Variant, Result As Variant, Parts() As String
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Data = Range("A1").CurrentRegion
  ReDim Result(1 To Evaluate("SUM(1+LEN(B2:B" & LastRow & ")-LEN(SUBSTITUTE(B2:B" & LastRow & ","","","""")))"), 1 To 2)
  For R = 2 To UBound(Data)
    Parts = Split(Data(R, 2), ",")
    For Z = 0 To UBound(Parts)
      X = X + 1
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Parts(Z)
    Next
  Next
  Range("D1:E1").Value = Array("Name", "Item")
  Range("D2").Resize(UBound(Result), 2) = Result
End Sub[/td]
[/tr]
[/table]

Note: I assumed your data was in Columns A and B, so I outputted the results to Columns D and E.

 

[juxel]

Rick, you are my hero. This worked perfectly. I cannot thank you enough.

 

[KeepTrying]

Dear juxel,
Another code for you to consider. Here you can select input and output range:

Sub One_to_One()


'https://www.mrexcel.com/forum/excel-questions/1034141-reformatting-data-1-many-1-1-a.html
'KeepTrying


Dim i As Long, D As Object, X, InputRange As Range, OutRange As Range, Z As Long, Tomb, j As Long


Set D = CreateObject("scripting.dictionary")


On Error GoTo Vege
Set InputRange = Application.InputBox("Select input range with header!", , , , , , , 8)
On Error GoTo 0
If InputRange.Columns.Count <> 2 Then
    MsgBox "Select InputRange with two columns!", , ""
    Exit Sub
End If


For i = 1 To InputRange.Rows.Count
    D(CStr(InputRange.Cells(i, 1) & ", " & InputRange.Cells(i, 2))) = "" 'assuming data are in first (Person) and second (Item) column in selected InputRange
Next i


On Error GoTo Vege
Set OutRange = Application.InputBox("Select a cell where you want to add output data!", , , , , , , 8)
On Error GoTo 0
If OutRange.Count <> 1 Then
    MsgBox "Select one cell only!", , ""
    Exit Sub
End If


Application.ScreenUpdating = False


X = D.keys
For i = 0 To D.Count - 1
    If i = 0 Then Z = 1
    Tomb = Split(X(i), ",")
    OutRange.Cells(Z, 1).Resize(UBound(Tomb), 1) = Tomb
    For j = LBound(Tomb) + 1 To UBound(Tomb) 'excluding LBound(Tomb) which is name of Person here
        OutRange.Cells(Z + j - 1, 2) = Tomb(j)
    Next j
    Z = Z + UBound(Tomb)
Next i


Application.ScreenUpdating = True


Vege:
End Sub

Best Regards,

 

[Norie]

May as well throw this in.

 

[Joe4]

Regarding the link that Norie provided of the post you made to another site, while we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html).

This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

For a more complete explanation on cross-posting, see here: http://www.excelguru.ca/content.php?184).
You will find that most Excel forums have similar policies.

 

[lhartono]

Another code that will include People without an item.

[COLOR=#0000cd]Sub OneToOne()
[/COLOR][COLOR=#d3d3d3]'by lhartono[/COLOR][COLOR=#0000cd]
Dim arrPeople As Variant, arrItem As Variant, Item As Variant
Dim x As Long, y As Long, z As Long
    
    Range("D1:E1") = Array("People", "Item")
    y = (Range("A" & Rows.Count).End(xlUp).Row)
    
    For x = 2 To y
        arrPeople = Range("A" & x, "B" & x)
        arrItem = VBA.Split(arrPeople(1, 2), ",")
        
        z = Range("D" & Rows.Count).End(xlUp).Row + 1
        
        If UBound(arrItem) = -1 Then
            Range("D" & z) = arrPeople(1, 1)
        End If
        
        For Each Item In arrItem
            Range("D" & z) = arrPeople(1, 1)
            Range("E" & z) = Trim$(Item)
            z = z + 1
        Next
    Next
End Sub[/COLOR]