"Pivoting" data with VBA I've attempted to erite some VBA for this this question.  The output is OK



but the code is not very elegant.  I'm happy-ish with creating unique list of names and certificates, but the rest seems rather ugly.  I'd love to learn how to make it more elegant and programmer-like (and less amateur-like-crap).

Sub PivotData()

    Dim rng As Range, cll As Range
    Dim arr As New Collection, a
    Dim var() As Variant
    Dim l As Long
    Dim lRow As Long, lCol As Long

    l = 1

    Set rng = Range("A2:C7")

    ' Create unique list of names
    var = Range("A2:A7")
    On Error Resume Next
    For Each a In var
        arr.Add a, a

    Next
    For l = 1 To arr.Count
        Cells(l + 1, 5) = arr(l)
    Next
    Set arr = Nothing

    ' Create unique list of certificates
    var = Range("B2:B7")
    For Each a In var
        arr.Add a, a
    Next
    For l = 1 To arr.Count
        Cells(1, 5 + l) = arr(l)
    Next
    Set arr = Nothing
    On Error GoTo 0

    ' Ugly code, how to make it more elegant?
    Range("F2").FormulaArray = _
        "=IFERROR(INDEX(R2C3:R7C3,MATCH(1,((R2C1:R7C1=RC5)*(R2C2:R7C2=R1C)),0)),"""")"

    With Range("F2")
        lRow = .CurrentRegion.Rows.Count
        lCol = .CurrentRegion.Columns.Count + 4
    End With

    Range("F2:F" &amp; lRow).FillDown
    Range(Cells(2, 6), Cells(lRow, lCol)).FillRight

End Sub
Fully Qualify Ranges

Your code assumes that the correct worksheet will be active when the code is ran.  You should get in the habit of Fully Qualifying all range references.  This will ensure that your code will work as intended no matter what worksheet is activated.

Technically, to be fully Fully Qualified a range needs to be referenced by workbook and worksheet.


  ThisWorkbook.Worksheets("Sheet1").Range ("A2:C7")


Or


  Workbooks("Some Book").Worksheets("Sheet1").Range ("A2:C7")


But in general it is acceptable to exclude the workbook if you are not going to be working with multiple workbooks.


  Worksheets("Sheet1").Range ("A2:C7")


With statement blocks should be used so that you don't have to repeatedly requalify your ranges.


  With ThisWorkbook.Worksheets("Sheet1")
  
  For Each a in .Range ("A2:C7")


Dynamic Ranges and Relative References

Dynamic Ranges should be used when working with records.  In this way, you will not have to rewrite you code every time a recorded is added or deleted.

This applies to both ranges


With ThisWorkbook.Worksheets("Sheet1")
    With .Range("A2", .Range("A" &amp; .Rows.Count).End(xlUp))
        For Each a In .Cells
            arr.Add a, a
        Next
    End With
End With



and formulas and FormulaArray


Range("F2").FormulaArray = "=IFERROR(INDEX(OFFSET($C1,1,0,COUNTA($A:$A)-1,1),MATCH(1,((OFFSET($A1,1,0,COUNTA($A:$A)-1,1)=$E2)*(OFFSET($B1,1,0,COUNTA($A:$A)-1,1)=F$1)),0)),"""")"



Having the macro hard the ranges for the FormulaArray is an acceptable middle ground.  I would do this to prevent the formulas from slowing up the workbook.

Error Handling

It is best to reduce the scope of On Error Resume Next as much as possible.  This will give you better information when something goes wrong.


On Error Resume Next
For Each a In var
    arr.Add a, a
Next
On Error GoTo 0



Or

For Each a In var
    On Error Resume Next
    arr.Add a, a
    On Error GoTo 0
Next


Variable Naming

Don't not use l as a variable name.  It is too hard to distinguish from 1.

l = 1 does nothing.  The For l = 1 initiates l to 1.

arr should only be used to name arrays variables.  Personally, I default to data, result or results.

Although there is nothing wrong with a, I prefer v, key, or item.



Alternate Methods

Here are some other ways of pivoting the data without using worksheet formulas.

Indexing Array Using ArrayList to Sort Headers

This uses ArrayList to store and sort the headers.  The position of the headers in the ArrayList is used as indices for a 2 dimensional array.

Sub PivotDataIndexedArray()
    Dim key As Variant, data() As Variant
    Dim rowHeaders As Object, columnHeaders As Object
    Set rowHeaders = CreateObject("System.Collections.ArrayList")
    Set columnHeaders = CreateObject("System.Collections.ArrayList")

    With ThisWorkbook.Worksheets("Sheet1")
        With .Range("A2", .Range("A" &amp; .Rows.Count).End(xlUp))
            For Each key In .Value
                If Not rowHeaders.Contains(key) Then rowHeaders.Add key
            Next
            For Each key In .Offset(0, 1).Value
                If Not columnHeaders.Contains(key) Then columnHeaders.Add key
            Next

            data = .Cells.Resize(, 3).Value
        End With

        Dim results() As Variant
        Dim n As Long
        ReDim results(1 To rowHeaders.Count + 2, 1 To columnHeaders.Count + 2)

        'Add names
        rowHeaders.Sort
        For n = 0 To rowHeaders.Count - 1
            results(n + 2, 1) = rowHeaders(n)
        Next

        'Add categories
        columnHeaders.Sort
        For n = 0 To columnHeaders.Count - 1
            results(1, n + 2) = columnHeaders(n)
        Next

        Dim r As Long, c As Long

        'Add dates
        For n = 1 To UBound(data)
            r = rowHeaders.IndexOf(data(n, 1), 0)
            c = columnHeaders.IndexOf(data(n, 2), 0)
            results(r + 2, c + 2) = data(n, 3)
        Next

        .Range("F1").Resize(UBound(results), UBound(results, 2)).Value = results

    End With

End Sub


ADODB CrossTab Query

An ADODB.Connection query can be used to pivot the data.  The source data should be the only data on the worksheet, otherwise, you would have to specify the datas' range on the worksheet in the query (e.g [Sheet1$A1:C7]).

Sub PivotDataADODBQuery()
    Const SQL As String = "TRANSFORM First([Date])" &amp; vbNewLine &amp; _
          "SELECT [Name]" &amp; vbNewLine &amp; _
          "FROM [Sheet1$]" &amp; vbNewLine &amp; _
          "GROUP BY [Name]" &amp; vbNewLine &amp; _
          "PIVOT [Certificate];"

    Dim conn As Object
    Dim rs As Object
    Set conn = CreateObject("ADODB.Connection")

    conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" &amp; ThisWorkbook.FullName &amp; "';Extended Properties='Excel 12.0;HDR=YES;IMEX=1';"
    conn.Open

    Set rs = conn.Execute(SQL)

    With ThisWorkbook.Worksheets("Sheet2")
        .Cells.ClearContents

        Dim c As Long

        For c = 0 To rs.Fields.Count - 1
            .Cells(1, c + 1).Value = rs.Fields(c).Name
        Next

        .Range("A2").CopyFromRecordset rs
    End With

    rs.Close
    conn.Close

End Sub