Transposing and clearing cells to tidy up data

ashbee

New Member
Joined
Sep 16, 2019
Messages
20
I’m hoping someone can help – I have used text to columns to split out products that had been entered into one cell and were separated by a comma. I then ran a macro to duplicate the rows based on the number of products to give each product its own row of data.

But now I’m stuck as I don’t know how to clean up the products so that I am left with 1 column that shows each individual product allowing me to delete columns 2-6. So in the example below this would result in a column that contained BIOL23, BIOL33, MICR3, BIOL5 AND MICR2.

I have 5 helper columns because I have instances of up to 5 products entered into one column!
Any advice would be appreciated.

Count
Column2
Column3
Column4
Column5
Column6
Type
Note
EntryID
3
BIOL23
BIOL33
MICR3


PART
Computation
8
3
BIOL23
BIOL33
MICR3


PART
Computation
8
3
BIOL23
BIOL33
MICR3


PART
Computation
8
2
BIOL5
MICR2



IND
Computation3
56
2
BIOL5
MICR2



IND
Computation3
56

<tbody>
</tbody>
 
Old fashion macro
Code:
Option Explicit


Sub Treat()
Const WsN = "Result"
Dim WkWs As Worksheet
Dim DstWs As Worksheet
Dim LR As Integer, I As Integer, J   As Integer
Dim LLR  As Range
Dim AAA, BBB
    
    Set WkWs = ActiveSheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(WsN).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add.Name = WsN
    Set DstWs = Sheets(WsN)
    Application.ScreenUpdating = False
    With WkWs
        LR = .Cells(Rows.Count, 1).End(3).Row
        DstWs.Cells(1, 1).Resize(1, 6) = Array("Person", "COUNT", "Type", "Note", "Date", "Day Time")
        LR = .Cells(Rows.Count, 1).End(3).Row
        For I = 2 To LR
            For J = 1 To 6
                If (.Cells(I, 1 + J) <> "") Then
                    Set LLR = DstWs.Cells(Rows.Count, "A").End(3)
                    .Cells(I, 1 + J).Copy LLR(2)
                    Range(.Cells(I, 8), .Cells(I, Columns.Count).End(xlToLeft)).Copy _
                     Destination:=LLR(2, 2)
                End If
            Next J
        Next I
    End With
    Application.ScreenUpdating = True
    MsgBox (" Job Done")
End Sub
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

Forum statistics

Threads
1,213,506
Messages
6,114,027
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top