I have to deal with some massive excel files extracting data from SAP and the problem I find is the following:

I obtain a list with multiple IDs, each one with some associated data. Particularly, SAP gives some attributes for that ID in several rows (features in the example table), which I would like to put in columns and have just one row per each ID, as it appears in the second table of the image. These features can have alphanumeric values or even Yes/No values (for example feature 1 can be "available in stock?" and its feature value could be "Yes", while Feature 4 could be another ID).

Example tables, before and after:

I would like to have a macro for doing this kind of sorting.

I have to deal with some massive excel files extracting data from SAP and the problem I find is the following:

I obtain a list with multiple IDs, each one with some associated data. Particularly, SAP gives some attributes for that ID in several rows (features in the example table), which I would like to put in columns and have just one row per each ID, as it appears in the second table of the image. These features can have alphanumeric values or even Yes/No values (for example feature 1 can be "available in stock?" and its feature value could be "Yes", while Feature 4 could be another ID).

Example tables, before and after:

I would like to have a macro for doing this kind of sorting.

• excel
• vba

• Please share the details of the code you tried and describe the issue you are encountering. PowerQuery is a good option if you don't know VBA coding. – taller Commented Mar 14 at 16:42

3 Answers 3

You can also do this with a worksheet formula:

=LET(
    d, Table1,
    PIVOTBY(
        CHOOSECOLS(d, 1, 2, 3, 4, 7),
        CHOOSECOLS(d, 5),
        CHOOSECOLS(d, 6),
        CONCAT,
        0,
        0,
        ,
        0
    )
)

or: (longer formula but has all the column headers and the dashes in empty features):

=LET(
    t, Table1[#All],
    d, DROP(t, 1),
    h, CHOOSECOLS(TAKE(t, 1), 1, 2, 3, 4, 7),
    p, PIVOTBY(
        CHOOSECOLS(d, 1, 2, 3, 4, 7),
        CHOOSECOLS(d, 5),
        CHOOSECOLS(d, 6),
        CONCAT,
        0,
        0,
        ,
        0
    ),
    a, VSTACK(HSTACK(h, DROP(TAKE(p, 1), , 5)), DROP(p, 1)),
    dash, MAP(a, LAMBDA(a, IF(a = "", "-", a))),
    dash
)

PowerQuery is a great option for processing data without using VBA coding.

• Pivot Feature column
• Replace blank with -
• Reorder the columns

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", type text}, {"Title", type text}, {"Status", Int64.Type}, {"Date", type text}, {"Feature", type text}, {"Feature Value", type any}, {"Author", type text}}),
    #"Pivoted Column" = Table.Pivot(#"Changed Type", List.Distinct(#"Changed Type"[Feature]), "Feature", "Feature Value"),
    #"Replaced Value" = Table.ReplaceValue(#"Pivoted Column",null,"-",Replacer.ReplaceValue,{"Feature 1", "Feature 2", "Feature 3", "Feature 4", "Feature 5"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Replaced Value",{"ID", "Title", "Status", "Date", "Feature 1", "Feature 2", "Feature 3", "Feature 4", "Feature 5", "Author"})
in
    #"Reordered Columns"

To round things out, here's a basic VBA approach

Sub TestPivot()
    Dim data, pivot
    
    data = Sheet3.Range("A1:G10").Value
    
    pivot = PivotData(data, Array("ID", "Title", "Status", "Date", "Author"), "Feature", "Feature Value")
    
    With Sheet3.Range("J1")
        .Resize(100, 100).Clear 'remove any previous content
        .Resize(UBound(pivot, 1), UBound(pivot, 2)).Value = pivot
    End With

End Sub

'Pivot data in 1-based 2D array `arrIn` and return as a 2D array
'  keyCols = array of column names to be used in composite key
'  pivotCol = column header to pivot on
'  valueCol = column header for pivot *values*
Function PivotData(arrIn, keyCols, pivotCol As String, valueCol As String)
    Dim pCols As Object, headerMapIn As Object, headerMapOut As Object, rowMapOut As Object, v, cat
    Dim arrOut, k, c As Long, cOut As Long, h As String, r As Long, key As String, sep As String, el
    
    Set headerMapIn = HeaderMap(arrIn) 'map the header positions in the input data
    Set pCols = ValueMap(arrIn, headerMapIn(pivotCol)) 'get unique pivot category values
    'resize the output array (may be longer than needed for all data to fit)
    ReDim arrOut(1 To UBound(arrIn), 1 To (UBound(arrIn, 2) - 2) + pCols.Count)
    
    'populate the headers in the output array
    Set headerMapOut = GetDict()
    For c = 1 To UBound(arrIn, 2)
        h = CStr(arrIn(1, c))
        If InArray(keyCols, h) Then
            headerMapOut(h) = headerMapOut.Count + 1
            arrOut(1, headerMapOut.Count) = h
        ElseIf h = pivotCol Then
            For Each k In pCols 'insert the pivot category values here as headers
                '<todo> Check pivot column category headers don't conflict
                '       with an existing key column header
                headerMapOut(CStr(k)) = headerMapOut.Count + 1 'add to map
                arrOut(1, headerMapOut.Count) = k              'add the header
            Next k
        End If
    Next c
    
    'now fill the output array
    Set rowMapOut = GetDict()
    For r = 2 To UBound(arrIn) 'skip headers
        key = "" 'reset these
        sep = ""
        For Each el In keyCols 'create the composite "key" for this row
            key = key & sep & arrIn(r, headerMapIn(el))
            sep = "|" 'populate separator after first value
        Next el
        If Not rowMapOut.Exists(key) Then            'new key?
            rowMapOut.Add key, rowMapOut.Count + 2   'add to row map (starting at row2)
            For Each el In keyCols                   'populate the key values for this row
                arrOut(rowMapOut(key), headerMapOut(el)) = arrIn(r, headerMapIn(el))
            Next el
        End If
        cat = arrIn(r, headerMapIn(pivotCol))   'pivot category
        v = arrIn(r, headerMapIn(valueCol))     'pivot value
        'any value to add?
        If Len(cat) > 0 And Len(v) > 0 Then
            'handle cases where a value already exists in this position. Concatenate?
            curr = arrOut(rowMapOut(key), headerMapOut(cat))
            curr = curr & IIf(Len(curr) > 0, ",", "") & v
            arrOut(rowMapOut(key), headerMapOut(cat)) = curr
        End If
    Next r
    '<todo>Truncate `arrout` to remove any empty rows
    PivotData = arrOut
End Function

'get a dictionary of unique values from column# `colNum` in 1-based 2D array `arr`
Function ValueMap(arr, colNum As Long) As Object
    Dim r As Long, d As Object
    Set d = GetDict()
    For r = 2 To UBound(arr, 1) 'skip headers
        d(CStr(arr(r, colNum))) = True
    Next r
    Set ValueMap = d
End Function

'Given a 1-based 2D array, return a dictionary mapping each value in the first row
'   to its column index.
Function HeaderMap(arr) As Object
    Dim c As Long, h As String
    Set HeaderMap = GetDict()
    For c = 1 To UBound(arr, 2)
        h = arr(1, c)
        If Not HeaderMap.Exists(h) Then
            HeaderMap.Add h, c
        Else
            Err.Raise -999, , "Duplicate header in input table: " & h
        End If
    Next c
End Function

'Return a case-insensitive scripting dictionary
Function GetDict() As Object
    Set GetDict = CreateObject("scripting.dictionary")
    GetDict.CompareMode = 1 'case-insensitive
End Function

'Is value `v` in array `arr`?
Function InArray(arr, v) As Boolean
    Dim el
    For Each el In arr
        If el = v Then
            InArray = True
            Exit Function
        End If
    Next el
End Function

Example: