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

I need to convert it into:-

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

I used the below (based on Ben McCormack's suggestion posted on Nov 23 '09) but it doesn't produce the above result :-

Sub NormalizeSheet()
Dim wsOriginal As Worksheet
Dim wsNormalized As Worksheet
Dim strKey As String
Dim clnHeader As Collection
Dim lngColumnCounter As Long
Dim lngRowCounterOriginal As Long
Dim lngRowCounterNormalized As Long
Dim rngCurrent As Range
Dim varColumn As Variant

Set wsOriginal = ThisWorkbook.Worksheets("Original")     'This is the name of your original worksheet'
Set wsNormalized = ThisWorkbook.Worksheets("Normalized") 'This is the name of the new worksheet'
Set clnHeader = New Collection

wsNormalized.Cells.ClearContents        'This deletes the contents of the destination worksheet'

lngColumnCounter = 2
lngRowCounterOriginal = 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)

' We'll loop through just the headers to get a collection of header names'
Do Until IsEmpty(rngCurrent.Value)
    clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter)
    lngColumnCounter = lngColumnCounter + 1
    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
Loop

'Here we'll reset our Row Counter and loop through the entire data set'
lngRowCounterOriginal = 2
lngRowCounterNormalized = 1
lngColumnCounter = 1

Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))

    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
    strKey = rngCurrent.Value ' Get the key value from the current cell'
    lngColumnCounter = 2

    'This next loop parses the denormalized values for each row'
    Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
        Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)

        'We're going to check to see if the current value'
        'is equal to NULL. If it is, we won't add it to'
        'the Normalized Table.'
        If rngCurrent.Value = "NULL" Then
            'Skip it'
        Else
            'Add this item to the normalized sheet'
            wsNormalized.Range("A" & lngRowCounterNormalized).Value = strKey
            wsNormalized.Range("B" & lngRowCounterNormalized).Value = clnHeader(CStr(lngColumnCounter))
            wsNormalized.Range("C" & lngRowCounterNormalized).Value = rngCurrent.Value
            lngRowCounterNormalized = lngRowCounterNormalized + 1
        End If

        lngColumnCounter = lngColumnCounter + 1
    Loop
    lngRowCounterOriginal = lngRowCounterOriginal + 1
    lngColumnCounter = 1    'We reset the column counter here because we're on a new row'
Loop



End Sub

Answer 1

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

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

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