Looking For Suggestions (Reformatting/ Transposing Data)

[Starstick]

Hi all,

I'm a bit of an excel newbie and am looking for suggestions for any functions/ scripts that will help with my reformatting problem!

I currently have a data set with three subheadings. (Number, Name and Fruit.) Currently each row represents a customer with an individual Number and Name who then have varying fruit values held on the same row. However, I now need to reformat the data so that the fruit values will now be held on separate rows per customer. (Example below.)

Currently:

NUMBER	NAME	FRUIT	FRUIT	FRUIT
101	Nathan	Apple	Pear
102	Chloe	Pear	Peach
103	Steffan	Apple	Banana	Pear
104	Glen	Banana	Pear

<tbody>
</tbody>

End Goal:

NUMBER	NAME	FRUIT
101	Nathan	Apple
101	Nathan	Pear
102	Chloe	Pear
102	Chloe	Peach
103	Steffan	Apple
103	Steffan	Banana
103	Steffan	Pear
104	Glen	Banana
104	Glen	Pear

<tbody>
</tbody>

I'm currently reviewing the data on a line by line basis and am creating new rows and transposing the data per customer but due to the multitude of data I'm looking for suggestions on if there is a better way to go about doing this as it's a little time consuming at the moment!

I'd appreciate any insight or suggestions that you could offer! Thank you in advance for any help.

Best wishes,
Starstick.

 

[Trebor76]

Hi Starstick,

Welcome to MrExcel!!

Here's one way to do it:

Option Explicit
Sub Macro4()

    Dim lngLastRow  As Long
    Dim lngMyRow    As Long
    Dim lngPasteRow As Long
    Dim i As Integer
    
    Application.ScreenUpdating = False

    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1 'Work backwards through the rows
        For i = 1 To Cells(lngMyRow, Columns.Count).End(xlToLeft).Column
            If i >= 4 Then 'Only copy and the clear data from Col. D on
                lngPasteRow = Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                Cells(lngPasteRow, 1) = Cells(lngMyRow, 1)
                Cells(lngPasteRow, 2) = Cells(lngMyRow, 2)
                Cells(lngPasteRow, 3) = Cells(lngMyRow, i)
                Cells(lngMyRow, i).ClearContents
            End If
        Next i
    Next lngMyRow
    
    'Sort the dataset by Col. A (Number)
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range(Cells(2, "A"), Cells(lngLastRow, "C")).Sort Key1:=Range("A2"), Order1:=xlAscending, Orientation:=xlSortColumns, Header:=xlYes
    
    Application.ScreenUpdating = True
    
End Sub

Just initially run it on a copy of your data as the results cannot be undone if they're not as expected.

Regards,

Robert