Excel - How can I transform data from columns into rows based on a specific value in a different column?

Question

I'm sorry if this is a dumb question, I have a rather elementary understanding of Excel's more complicated functions. Basically, I'm working with patient data and have run into kind of a road block because our data management system exports in a layout that's different than I'd need. We're talking to the point where I'm doubting whether what I need is even possible (Note: DoS is Date of Service). Here's what I have:

Acct#    DoS           Wt.    Ht.     Lab
12345    01/02/2019    143    62.5    5.8      
12345    04/027/2019   144    62.3    4.6      
14345    01/06/2019    167    57.3    6.8      
14345    02/03/2019    172    57.7    6.7
14345    02/15/2019    174    57.6    6.6   

I have no idea how to transform the data but I need it to end up formatted as:

Acct#   DoS_1     Wt.  Ht.   Lab   DoS_2       Wt.    Ht.     Lab.   DoS_3     Wt.
12345   01/02/19  143  62.5  5.8   04/27/2019  144    62.3    4.6      -        -  
14345   01/06/19  167  57.3  6.8   02/03/2019  172    57.7    6.7   02/15/19   174

There are some account numbers that will only have one encounter. There are others that may have two or even twelve. I have no idea how to use VBA, but am fairly sure that I can plug the values and cells in the right place with some guidance, in the event that there is a function of existing script that could perform this action

Answer 1

See if this works for you.

You need to create a new worksheet within your workbook and set the technical name to shTransformed . Do this by going into the VBA editor (Alt + F11) and changing it as shown below ...

Then add a new module (in the VBA editor, go to Insert->Module ) and add the code as shown below ...

Public Sub TransformToColumnsByAcct()
    Dim rngSrcData As Range, i As Long, objDict As Scripting.Dictionary, strKey As String, arrRows As Variant
    Dim lngHeaderStartCol As Long, x As Long, lngSrcRow As Long, lngWriteRow As Long, lngMaxUbound As Long

    Set rngSrcData = Selection
    Set objDict = New Scripting.Dictionary

    With rngSrcData
        ' Get all of the unique accounts, this will also determine for us the amount of columns we need to provide for.
        ' Start from the 2nd row because the 1st contains the header.
        For i = 2 To .Rows.Count
            strKey = .Cells(i, 1)

            If Not objDict.Exists(strKey) Then
                objDict.Add strKey, Array(i)
            Else
                arrRows = objDict.Item(strKey)
                ReDim Preserve arrRows(UBound(arrRows) + 1)
                arrRows(UBound(arrRows)) = i

                objDict.Item(strKey) = arrRows

                If UBound(arrRows) > lngMaxUbound Then
                    lngMaxUbound = UBound(arrRows)
                End If
            End If
        Next

        ' Clear all of the cells in the destination worksheet.
        shTransformed.Cells.Clear

        ' Add the header for the key field.
        shTransformed.Cells(1, 1) = .Cells(1, 1)

        lngHeaderStartCol = 2

        ' Now get all of the column headers excluding the first as this contains the key and write them to the
        ' transformed worksheet.  Dynamically increment the 2nd header by 1 each time.
        For i = 1 To lngMaxUbound + 1
            ' Determine the start column for the header to be copied to factoring in the first field.
            If i > 1 Then
                lngHeaderStartCol = lngHeaderStartCol + .Columns.Count - 1
            End If

            .Range(.Cells(1, 2).Address & ":" & .Cells(1, .Columns.Count).Address).Copy shTransformed.Cells(1, lngHeaderStartCol)

            ' Incremement the header text by 1 and put an underscore.
            shTransformed.Cells(1, lngHeaderStartCol) = shTransformed.Cells(1, lngHeaderStartCol) & "_" & i
        Next

        ' Now write out all of the unique keys to the transformed sheet along with the data.
        For i = 0 To objDict.Count - 1
            strKey = objDict.Keys(i)
            arrRows = objDict.Item(strKey)

            lngWriteRow = i + 2

            ' Write the key to the first column.
            shTransformed.Cells(lngWriteRow, 1) = strKey

            lngHeaderStartCol = 2

            ' Now process each row of data for the unique key.
            For x = 0 To UBound(arrRows)
                lngSrcRow = arrRows(x)

                If x > 0 Then
                    lngHeaderStartCol = lngHeaderStartCol + .Columns.Count - 1
                End If

                ' Copy the data for the given row to the transformed sheet.
                .Range(.Cells(lngSrcRow, 2).Address & ":" & .Cells(lngSrcRow, .Columns.Count).Address).Copy shTransformed.Cells(lngWriteRow, lngHeaderStartCol)
            Next
        Next
    End With
End Sub

Next, in the VBA editor, go to Tools->References and add in the reference ...

Microsoft Scripting Runtime

Now go back to your sheet with the raw data, select it all and then go to Developer->Macros (If you can't see the developer menu in your ribbon, Google it.) and run the macro and see how it goes.

If you look at the transformed sheet, you should see your result.

Here's hoping it works for you.