Make horizontal list vertical in Excel

Question

I have the need to turn a part of a horisontal list vertical. I have tried using TRANSPOSE without any success.

Using one VBA script I have inserted blank rows beneath the four or five digit product number. And I want to move (or copy/paste) values shown in image.

Excel list

I modified a VBA script given to me (credit given to TheAtomicOption), but Excel stalls when I run it:

Sub Sizes()

'figure out how far down data goes
Range("A1").Select
Selection.End(xlDown).Select
Dim endrow
endrow = Selection.Row

'always start in the correct column
Range("D1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Activate

Dim rownumber

'loop through all data
Do While ActiveCell.Row < endrow
    'Store cell of current base name
    rownumber = ActiveCell.Row


    'loop through empty cells and set formula if cell isn't empty
    Do While True
        ActiveCell.Offset(1, 0).Activate

        'if next cell isn't empty, isn't past the end of the list, go to outer loop
        If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
            ActiveCell.Offset(0, 1).Formula = "=E(" & rownumber & ")"
        ActiveCell.Offset(1, 0).Activate

        If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
            ActiveCell.Offset(0, 1).Formula = "=F(" & rownumber & ")"
        ActiveCell.Offset(1, 0).Activate

        If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
            ActiveCell.Offset(0, 1).Formula = "=G(" & rownumber & ")"
        ActiveCell.Offset(1, 0).Activate

        If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
            ActiveCell.Offset(0, 1).Formula = "=H(" & rownumber & ")"
        ActiveCell.Offset(1, 0).Activate

        If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
            ActiveCell.Offset(0, 1).Formula = "=I(" & rownumber & ")"
        ActiveCell.Offset(1, 0).Activate

        Else
            Exit Do
        End If
        End If
        End If
        End If
        End If

    Loop
Loop

End Sub

Any suggestions on how to solve, and how to improve the script?

EDIT: Column A is just a support column for Selection.End(xlDown).Select Column B is a counter for the sizes. It is for the initial script that inserted new rows. Column C is SKU/product ID Column D is the column where I want all the sizes listed. Column E-I and on the row with SKU is where the sizes now are listed.

How the end result should look

Edit 2:

Solution, thanks to script from QHarr.

Option Explicit

Sub Sizes()
Dim wb As Workbook
Dim ws As Worksheet

'figure out how far down data goes
Dim endrow As Long
Dim rownumber As Long

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Modified the sheet name

With ws
    endrow = .Cells(.Rows.Count, "A").End(xlUp).Row

   'always start in the correct column
    .Cells(.Cells(1, "D").End(xlDown).Row, "D").Offset(, -1).Activate

   'loop through all data
    Do While ActiveCell.Row < endrow

       'loop through empty cells and set formula if cell isn't empty
        Do While ActiveCell.Row <= endrow

       'Set rownumer at new product id

        rownumber = ActiveCell.Row

            ActiveCell.Offset(1, 0).Activate

          'if next cell isn't empty, isn't past the end of the list, go to outer loop
            If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
                ActiveCell.Offset(0, 1).Formula = "=E" & rownumber
                ActiveCell.Offset(1, 0).Activate

            If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
                ActiveCell.Offset(0, 1).Formula = "=F" & rownumber
                ActiveCell.Offset(1, 0).Activate

            If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
                ActiveCell.Offset(0, 1).Formula = "=G" & rownumber
                ActiveCell.Offset(1, 0).Activate

            If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
                ActiveCell.Offset(0, 1).Formula = "=H" & rownumber
                ActiveCell.Offset(1, 0).Activate

           If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
               ActiveCell.Offset(0, 1).Formula = "=I" & rownumber
               ActiveCell.Offset(1, 0).Activate

           Else
               Exit Do
           End If
           End If
           End If
           End If
           End If
        Loop
     Loop

End With

End Sub

Answer 1

Here is a method using Get & Transform (Excel 2016) or Power Query (Excel 2010,2013)

Assuming this is your original data:

• Go to Data -> Get & Transform (or Power Query for earlier versions)

• Select the Product# column and Change the type to Text. (this can be omitted if you are sure that none of your Product#'s will ever be text)

• UNPIVOT the other columns (the various Size columns)

• Delete the Attribute column (this will contain a listing of the column headers)
• Rename the remaining Column Size
• Close and save the query

• Apply conditional formatting to column A, with applies to: covering the entire column of data (eg: $A$2:$A$26)

• CF Formula: =COUNTIF($A$2:$A2,$A2)>1

• CF Format: Numberformat: ;;;

If you add or delete rows from your original data, you can Refresh the query and the results table will auto-update.

If you need to add extra columns to the results, you can probably do that within the query editor.

Credits to @TotsieMae for help with the Conditional Formatting formula. See Get & Transform vs Conditional Format

Answer 2

I haven't optimized this code but see if this works. I have added references to the workbook and target worksheet. You need to amend to your target worksheet name.

Added variables that are declared with datatype.

Single Do loop with exit condition that can be met.

Corrected syntax and removed offset for each of the lines with the following format: ActiveCell.Offset(0, 1).Formula = "=E(" & rownumber & ")"

You needed ActiveCell.Formula = "=E" & rownumber

Note: I am assuming you are looping one column so only one loop needed. Original code with 2 loops you would have needed Do While ActiveCell.Row < endrow for both loops and ActiveCell.Formula = "=E" & rownumber + 1 etc.

Option Explicit

Sub Sizes()
Dim wb As Workbook
Dim ws As Worksheet
Dim endrow As Long
Dim rownumber As Long

Set wb = ThisWorkbook
Set ws = wb.Sheets("TargetSheetName")

With ws

    'figure out how far down data goes (assuming last row in A is also last in D)
    endrow = .Cells(.Rows.Count, "A").End(xlUp).Row

   'always start in the correct column
    .Cells(.Cells(1, "D").End(xlDown).Row, "D").Offset(-1, 0).Activate

   'loop through all data
    Do While ActiveCell.Row < endrow
        'Store cell of current base name
        rownumber = ActiveCell.Row
        ActiveCell.Offset(1, 0).Activate

        'if next cell isn't empty, isn't past the end of the list, go to _
    outer loop
         If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
             ActiveCell.Formula = "=E" & rownumber   
             ActiveCell.Offset(1, 0).Activate

         If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
             ActiveCell.Formula = "=F" & rownumber 
             ActiveCell.Offset(1, 0).Activate

         If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
             ActiveCell.Formula = "=G" & rownumber 
             ActiveCell.Offset(1, 0).Activate

         If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
             ActiveCell.Formula = "=H" & rownumber 
             ActiveCell.Offset(1, 0).Activate

         If ActiveCell.Formula = "" And ActiveCell.Row <= endrow Then
             ActiveCell.Formula = "=I" & rownumber 
             ActiveCell.Offset(1, 0).Activate

         Else
             Exit Do
         End If
         End If
         End If
         End If
         End If 
      Loop
End With

End Sub