I am looking for small help. I have data in four column with serial number, Alert, Count and Group bases I want to change the data format from vertically to horizontal as below screen shot using vba. I have written some code for read the data from input worksheet and put in Scripting.Dictionary. But I do not know further how to display in horizontal format of column.

Input Data :

Expected Output :

Source code:

 Sub ConsecutiveHorizontal()
    Dim wsData As Worksheet, wsOut As Worksheet
    Dim dictSerNo As Object, dictAlert As Object, distAlertGroup
    
    Dim arData, arOut, k, rngOut As Range
    Dim lastrow As Long, i As Long
    Dim serNo As String, alert As String, alertGroup As String
    Dim r As Long, c As Long, t0 As Single: t0 = Timer
    
    Set dictSerNo = CreateObject("Scripting.Dictionary")
    Set dictAlert = CreateObject("Scripting.Dictionary")
    Set distAlertGroup = CreateObject("Scripting.Dictionary")
    
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("ConsecutiveOverview").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets.Add.Name = "OutputData"
    Set wsOut = Sheets("OutputData")
    Set wsData = Sheets("InputData")
    
    r = 1: c = 1
    With wsData
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row  'Device Serial Number
        arData = .Range("A1:D" & lastrow).Value2
       
        ' get unique serno and alert
        For i = 2 To lastrow
        
            serNo = arData(i, 1)  '50502154, 50502180 etc,
            alert = arData(i, 2)  '9501 ,   9301,    4142 etc
            alertGroup = arData(i, 4) ' 1 To 3, 4 To 8, 9 
            
            If dictSerNo.Exists(serNo) Then
            ElseIf Len(serNo) > 0 Then
                r = r   1
                dictSerNo.Add serNo, r
            End If
           
            If dictAlert.Exists(alert) Then
            ElseIf Len(alert) > 0 Then
                c = c   1
                dictAlert.Add alert, c
                 distAlertGroup.Add alert, alertGroup
            End If             
        Next
    End With
     
     ' add headers
    arOut(1, 1) = "Serial No"
    ' sernos and alerts
    For Each k In dictSerNo
        arOut(dictSerNo(k), 1) = k
    Next
    For Each k In dictAlert
        arOut(1, dictAlert(k)) = k
    Next
    
End Sub

CodePudding user response：

Here's something a little more generic (useful to have a less-specific pivoting method):

Sub ConsecutiveHorizontal()

    Const ROW_KEY_IDX As Long = 1
    Const COL_KEY_IDX As Long = 2
    Const VAL_KEY_IDX As Long = 4
    
    Dim wsData As Worksheet, wsOut As Worksheet, wb As Workbook
    Dim dictRow As Object, dictCol As Object
    Dim arData, arOut, i As Long, t0 As Single
    
    t0 = Timer
    
    Set wb = ThisWorkbook
    
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Sheets("OutputData").Delete  '?
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsData = wb.Sheets("InputData")
    Set wsOut = wb.Sheets.Add() 'get reference directly
    wsOut.Name = "OutputData"
    
    With wsData
        arData = .Range("A2:D" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value2
    End With
    'get unique column values and indexes
    Set dictRow = ArrayColumnUniques(arData, ROW_KEY_IDX)
    Set dictCol = ArrayColumnUniques(arData, COL_KEY_IDX)
    
    ReDim arOut(1 To dictRow.Count   1, 1 To dictCol.Count   1) 'resize output array
    arOut(1, 1) = "Serial No"
    
    'populate output array row and column headers
    For i = 1 To dictRow.Count
        arOut(i   1, 1) = dictRow.keys()(i - 1)
    Next i
    For i = 1 To dictCol.Count
        arOut(1, i   1) = dictCol.keys()(i - 1)
    Next i
    'populate output values - assumes only one value per unique row/column key combination
    For i = 1 To UBound(arData)
        arOut(dictRow(arData(i, ROW_KEY_IDX))   1, _
              dictCol(arData(i, COL_KEY_IDX))   1) = arData(i, VAL_KEY_IDX)
    Next i
    
    With wsOut.Range("B2")
        .Resize(UBound(arOut, 1), UBound(arOut, 2)).Value = arOut
    End With
    
End Sub

'return a dictionary with all unique values from array column `colIndex`
Function ArrayColumnUniques(arr As Variant, colIndex As Long) As Object
    Dim r As Long, i As Long, dict As Object, v
    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = 1 'vbTextCompare
    i = 0
    For r = LBound(arr, 1) To UBound(arr, 1)
        v = arr(r, colIndex)
        If Len(v) > 0 Then
            If Not dict.exists(v) Then
                i = i   1
                dict.Add v, i
            End If
        End If
    Next r
    Set ArrayColumnUniques = dict
End Function

CodePudding user response：

If you have Power Query, available in Windows Excel 2010 and Office/Excel 365, you can do this in basically two steps:

• Remove the Consecutive Count column
• Pivot Alert Code with Value = Consecutive Group and no aggregation:

All is doable from the UI
M Code

let

//change table name in next line to actual name in your worksheet
    Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],

//set the data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{
        {"Serial Number", Int64.Type}, 
        {"Alert Code", Int64.Type}, 
        {"Consecutive Count", Int64.Type}, 
        {"Consecutive Group", type text}}),

//Remove the Consecutive Count column
    #"Removed Columns" = Table.RemoveColumns(#"Changed Type",{"Consecutive Count"}),

//Pivot Alert Code
    #"Pivoted Column" = Table.Pivot(
        Table.TransformColumnTypes(#"Removed Columns", {{"Alert Code", type text}}, "en-US"), 
        List.Distinct(Table.TransformColumnTypes(#"Removed Columns", {{"Alert Code", type text}}, "en-US")[#"Alert Code"]), 
        "Alert Code", "Consecutive Group")
in
    #"Pivoted Column"