Transforming Longitudinal data to wide on excel/ VBA

Question

I have this dataset in excel where the data is longitudinal (picture 1), however do not have data for every year (1993-2014) in my output sheet. Essentially what I want to accomplish is make the dataset wide (example in picture 2), so the years there is data it should put the data but for years data is not available in source sheet (picture 1) it should leave it blank or put NA.

Answer 1

Transform Data

Pivot Table

• Select Insert > PivotTable. In the window that opens, select the source range and the destination cell and press OK.

• Drag Name to Rows, Year to Columns and Value to Values. Done!

Power Query

• Use Ctrl+T to convert the range to a table (mandatory).
• Select Data > From Table/Range to open the Power Query Editor.

• In the Power Query Editor select the Year column, the column to be pivoted, and select Transform > Pivot Column to open the Pivot Column dialog.

• In the Pivot Column dialog, under Values Column, select Value and under Advanced Options select Don't Aggregate and press OK. Select File > Close & Load To to exit the Power Query Editor.

• In the Import Data dialog, choose the type and location of the output and press OK.

• Done!

VBA

• Copy the code to a standard module, e.g. Module1.
• Adjust the values in the constants section and run the Pivot1R1C1V procedure. Done!

Option Explicit


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the pivoted three-column data in another worksheet.
' Calls:        RefCurrentRegion
'               GetPivot1R1C1V
'                   DictColumn
'                   QSort
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Pivot1R1C1V()
    Const ProcName As String = "Pivot1R1C1V"
    On Error GoTo ClearError
    
    Dim IsSuccess As Boolean
    
    Const sName As String = "Sheet1"
    Const sfcAddress As String = "A1"
    
    Const dName As String = "Sheet2"
    Const dfcAddress As String = "A1"
    
    Const FirstCellValue As String = "AEM Database"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = RefCurrentRegion(sws.Range(sfcAddress))
    
    Dim dData As Variant: dData = GetPivot1R1C1V(srg, True, , FirstCellValue)
    Dim drCount As Long: drCount = UBound(dData, 1)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfcAddress).Resize(drCount, UBound(dData, 2))
        .Value = dData
'        ' Convert to Excel table (just an idea; should be handled cleaner).
'        If dws.ListObjects.Count > 0 Then
'            dws.ListObjects(1).Delete
'        End If
'        dws.ListObjects.Add xlSrcRange, .Cells, , xlYes
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
        .EntireColumn.AutoFit
    End With
        
    IsSuccess = True
        
ProcExit:
    
    If IsSuccess Then
        MsgBox "Data transformed.", vbInformation, ProcName
    Else
        MsgBox "Something went wrong.", vbCritical, ProcName
    End If
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with the first cell
'               of a range and ending with the last cell of the first cell's
'               CurrentRegion.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegion"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
            - FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the pivoted data of a range ('srg')
'               in a 2D one-based array. The source data is in three columns.
'               The 1st element will be either the value from the first cell
'               (the Row Labels Header) or a given value ('FirstCellValue').
'               The 1st column is 'row labels' whose unique values will be
'               copied to the first column starting from the 2nd row.
'               The 2nd column is 'column labels' whose unique values will be
'               copied to the first row starting from the 2nd column.
'               The 3rd column is 'values' which will be copied
'               to the intersections of each associated row and column label.
' Calls:        DictColumn,QSort.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetPivot1R1C1V( _
    ByVal srg As Range, _
    Optional ByVal SortRowLabels As Boolean = False, _
    Optional ByVal SortColumnLabels As Boolean = False, _
    Optional ByVal FirstCellValue As Variant) _
As Variant
    Const ProcName As String = "GetPivot1R1C1V"
    On Error GoTo ClearError
    
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData As Variant: sData = srg.Value
     
    Dim rArr As Variant: rArr = DictColumn(sData, 1, 2).Keys
    If SortRowLabels Then QSort rArr, LBound(rArr), UBound(rArr)
    
    Dim vArr As Variant: vArr = DictColumn(sData, 2, 2).Keys
    If SortColumnLabels Then QSort vArr, LBound(vArr), UBound(vArr)
     
    Dim drCount As Long: drCount = UBound(rArr) + 2
    Dim dcCount As Long: dcCount = UBound(vArr) + 2
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' First Row
    
    Dim dc As Long
    ' First Column
    If IsMissing(FirstCellValue) Then
        FirstCellValue = sData(1, 1)
    End If
    dData(1, 1) = FirstCellValue
    ' Rest of the Columns
    For dc = 2 To dcCount
        dData(1, dc) = vArr(dc - 2)
    Next dc
    
    ' Rest of the Rows
    
    Dim dr As Long
    Dim sr As Long
    ' First Column
    For dr = 2 To drCount
        dData(dr, 1) = rArr(dr - 2)
    Next dr
    ' Rest of the Columns
    For sr = 2 To srCount
        dr = Application.Match(sData(sr, 1), rArr, 0) + 1
        dc = Application.Match(sData(sr, 2), vArr, 0) + 1
        dData(dr, dc) = sData(sr, 3)
    Next sr

    GetPivot1R1C1V = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column ('ColumnIndex'),
'               of a 2D array ('Data'), starting from a row,
'               in the keys of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumn( _
    ByVal Data As Variant, _
    Optional ByVal ColumnIndex As Variant, _
    Optional ByVal FirstRowIndex As Variant) _
As Object
    Const ProcName As String = "DictColumn"
    On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim r As Long
    If IsMissing(FirstRowIndex) Then
        r = LBound(Data, 1)
    Else
        r = CLng(FirstRowIndex)
    End If
    
    Dim c As Long
    If IsMissing(ColumnIndex) Then
        c = LBound(Data, 2)
    Else
       c = CLng(ColumnIndex)
    End If
    
    Dim Key As Variant
    
    For r = r To UBound(Data, 1)
        Key = Data(r, c)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
    
    Set DictColumn = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Using the quicksort algorithm, sorts an array ('Arr') ascending.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub QSort( _
        ByRef Arr As Variant, _
        ByVal LB As Long, _
        ByVal UB As Long)
    Dim Piv As Variant, Tmp As Variant, LO As Long, HI As Long
    LO = LB: HI = UB: Piv = Arr((LB + UB) \ 2)
    Do While LO <= HI
        Do While Arr(LO) < Piv: LO = LO + 1: Loop
        Do While Arr(HI) > Piv: HI = HI - 1: Loop
        If LO <= HI Then
            Tmp = Arr(LO)
            Arr(LO) = Arr(HI): Arr(HI) = Tmp: LO = LO + 1: HI = HI - 1
        End If
    Loop
    If LB < HI Then QSort Arr, LB, HI
    If LO < UB Then QSort Arr, LO, UB
End Sub