Macro to TRANSPOSE comma delimited cell into rows and copy down adjacent cells

Question

I have a spreadsheet in which there are rows of data entered which need to be split.

Currently, this is a manual process, I have provided a link to the workbook when I have split the steps I have been doing into worksheets:

https://www.dropbox.com/s/0p3fg94pa61e4su/Example.xlsx?dl=0

When done manually the logical process is to first split by columns E (Temp) and F (Location) as these are directly linked to each other, then insert a blank row underneath so they are separated as shown in the worksheet step 1.

Then the next step is to split by column B Samples and copy the rows down from above in the range A:Y to reach the end result.

What is the best way to approach this as I am to use keyboard shortcuts to make it quicker but if it is possible to put this into a macro would save literally hours a week!

Answer 1

I believe the following should work for you.

Sub strata_data()
    Dim t As Long, s As Long, rw As Long
    Dim vTEMPs As Variant, vSAMPLEs As Variant, vOVENs As Variant

    Application.ScreenUpdating = False

    With Worksheets("Start2") '<~~set this worksheet name correctly
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
            vSAMPLEs = Split(.Cells(rw, 2).Value2, Chr(44))
            vTEMPs = Split(.Cells(rw, 5).Value2, Chr(44))
            vOVENs = Split(.Cells(rw, 6).Value2, Chr(44))
            For t = UBound(vTEMPs) To LBound(vTEMPs) Step -1
                .Cells(rw + 1, 1).Resize(2 + (t = LBound(vTEMPs)), 1).EntireRow.Insert
                .Cells(rw, 1).Resize(1, 7).Copy Destination:=.Cells(rw + 1 + (t = LBound(vTEMPs)), 1)
                .Cells(rw + 1 + (t = LBound(vTEMPs)), 5) = CLng(vTEMPs(t))
                .Cells(rw + 1 + (t = LBound(vTEMPs)), 6) = vOVENs(t)
                .Cells(rw + 1 + (t = LBound(vTEMPs)), 5).NumberFormat = "0° \C"
                .Cells(rw + 2 + (t = LBound(vTEMPs)), 1).Resize(1, 25).ClearContents
                .Cells(rw + 2 + (t = LBound(vTEMPs)), 1).Resize(1, 25).Interior.Pattern = xlNone
                If CBool(UBound(vSAMPLEs)) Then
                    .Cells(rw + 1 + (t = LBound(vTEMPs)), 1).Resize(1, 25).Copy
                    .Cells(rw + 1 + (t = LBound(vTEMPs)), 1).Resize(UBound(vSAMPLEs), 25).Insert Shift:=xlDown
                    For s = UBound(vSAMPLEs) To LBound(vSAMPLEs) Step -1
                        .Cells(rw + 1 + s + (t = LBound(vTEMPs)), 2) = vSAMPLEs(s)
                    Next s
                End If
            Next t
        Next rw
    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

There were some ones in column to the right of column G. I didn't know if they were seeded data so I left them alone. You should be able to clear them out with a simple .ClearContents command if they are unnecessary.