Convert row with columns of data into column with multiple rows in Excel

Question

I hv rows of data:-

TAG   SKU   SIZE   GRADE   LOCATION
A001  123    12      A       X1
A002  789    13      B       X3
A003  456    15      C       X5


        

Answer 1

Here's an approach going from worksheet to worksheet directly. This might be necessary if the dataset is too big and available memory too small for using arrays. It's likely to be slow.

It uses the same call parameters as reOrgV1, and pretty much the same logic.

It's updated to add "DEFECTS" to the properies. The input looks like:

TAG     SKU   SIZE GRADE LOCATION DEFECTS
A001    123    12   A       X1      3
A002    789    13   B       X3      5
A003    456    15   C       X5      7

Here's the code.

Public Sub reOrgV2(inSource As Range, inTarget As Range)
'' This version works directly on the worksheet
'' and transfers the result directly to the target
'' given as the top-left cell of the result.

'' **** Changed to add "Defects"
    Dim resNames()
    Dim propNum As Integer
    Dim srcRows As Integer
    Dim resRows As Integer
    Dim i As Integer
    Dim j As Integer
    Dim g As Integer

    '' Shape the result
    resNames = Array("Size", "Grade", "Location", "Defects")
    propNum = 1 + UBound(resNames)

    '' Row counts
    srcRows = inSource.Rows.Count
    resRows = srcRows * propNum

    '' re-org and transfer source to result range
    inTarget = inTarget.Resize(resRows, 4)
    g = 1
    For i = 1 To srcRows
        For j = 0 To 3
            inTarget.Item(g + j, 1) = inSource.Item(i, 1)      '' Tag
            inTarget.Item(g + j, 2) = inSource.Item(i, 2)      '' SKU
            inTarget.Item(g + j, 3) = resNames(j)              '' Property
            inTarget.Item(g + j, 4) = inSource.Item(i, j + 3)  '' Value
        Next j
        g = g + propNum
    Next i
End Sub

This is the revised call sourcing the wider range.

'' Call ReOrgV2 with input and output ranges
Public Sub test4()
    Dim i As Integer
    i = Range("InData!A:A").Find("").Row - 2
    reOrgV2 Range("InData!A2").Resize(i, 6), [OutData!A1]
End Sub

Answer 2

Here's a really simple solution that assumes the dataset isn't huge. It takes the input range into an array, transforms it into a result array, then moves the array to the specified target. The target is defined by the top left cell.

When it's possible, this approach is orders of magnitude faster than working directly with cells on worksheets.

The test function at the bottom needs you to put an input set on sheet InData and have a sheet OutData defined for the results but your input and output ranges can be anywhere you want.

Option Explicit

Public Sub reOrgV1(inSource As Range, inTarget As Range)
'' This version uses VBA arrays to do the work.
'' Takes a source range, reorganizes it to the target
''    given as the top-left cell of the result.

    Dim srcArray As Variant
    Dim resArray As Variant
    Dim resNames()
    resNames = Array("SIZE", "GRADE", "LOCATION")

    Dim srcRows As Integer
    Dim resRows As Integer
    Dim i As Integer
    Dim j As Integer
    Dim g As Integer

    '' Move range into source array
    srcArray = inSource.Value
    srcRows = UBound(srcArray, 1)
    resRows = srcRows * 3

    ''Build result array
    ReDim resArray(1 To resRows, 1 To 3)

    '' transfer source to result array
    g = 1
    For i = 1 To srcRows
        For j = 0 To 2
            resArray(g + j, 1) = srcArray(i, 1)
            resArray(g + j, 2) = srcArray(i, 2)
            resArray(g + j, 3) = resNames(j) & " " & srcArray(i, j + 3)
        Next j
        g = g + 3
    Next i

    '' Move the results to the target range
    inTarget.Resize(resRows, 3).Value = resArray
End Sub

Public Sub test1()
    reOrgV1 Range("InData!A2:E4"), Range("OutData!A1")
End Sub

Answer 3

You can use ADO with Excel. Roughly:

Sub ColsToRows()
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer

    ''This is not the best way to refer to the workbook
    ''you want, but it is very convenient for notes
    ''It is probably best to use the name of the workbook.

    strFile = ActiveWorkbook.FullName

    ''Note that if HDR=No, F1,F2 etc are used for column names,
    ''if HDR=Yes, the names in the first row of the range
    ''can be used.
    ''This is the Jet 4 connection string, you can get more
    ''here : http://www.connectionstrings.com/excel

     strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Docs\TestBook.xls " _
            & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

    ''Late binding, so no reference is needed

    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")


    cn.Open strCon

    strSQL = "SELECT [TAG], [SKU], 'SIZE ' & [SIZE] As S, " _
           & "'GRADE ' & [GRADE] As G, 'LOCATION ' & [LOCATION] As L " _
           & "FROM [Sheet1$] a " _
           & "ORDER BY [Tag] "

    rs.Open strSQL, cn, 3, 3


    ''Pick a suitable empty worksheet for the results

    With Worksheets("Sheet3")

        j = 1 '' Row counter

        Do While Not rs.EOF
            For i = 2 To 4
                .Cells(j, 1) = rs!Tag
                .Cells(j, 2) = rs!SKU
                .Cells(j, 3) = rs(i)
                j = j + 1
            Next
            rs.MoveNext
        Loop
    End With

   ''Tidy up
   rs.Close
   Set rs = Nothing
   cn.Close
   Set cn = Nothing

End Sub