Combine every unique value from column A with duplicated values into a new sheet

Question

I need to combine each unique value in column A that has duplicate values into a new sheet. This value is duplicated, because every time the record in column A changes status, it creates a new row, with the new status and date of the change in column F.

I need to combine all this data in a single row for each unique value. I have tried it, but I don't know if it is the best way. Also, I have not been able to calculate the days between each status change in column F and neither I got him to order them from the oldest state to the newest.

I leave you an example of my sheet, with a single unique value and the code that I managed to run.

Sub Consolidate()
    ' Iniciamos declarando variables para las hojas de origen y destino
    Dim wsSource As Worksheet, wsDest As Worksheet
    ' Variables para iterar y almacenar la última fila de la hoja de origen
    Dim lastRow As Long, i As Long, j As Integer
    ' Diccionario para almacenar valores únicos y una variable para las claves
    Dim uniqueValues As Object, key As Variant
    ' Variables de rango para celdas y búsqueda
    Dim cell As Range, findRange As Range
    ' Variable para rastrear filas en la hoja de destino
    Dim destRow As Long
    Dim firstAddress As String ' Declaración faltante en el código original, necesaria para el control del bucle

    Set uniqueValues = CreateObject("Scripting.Dictionary") ' Usamos un diccionario en lugar de una colección

    ' Estableciendo las hojas de origen y destino
    Set wsSource = ThisWorkbook.Sheets("Report")
    Set wsDest = ThisWorkbook.Sheets.Add
    wsDest.Name = "Consolidated" ' Nombre para la nueva hoja

    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row ' Calcula la última fila con datos en la columna A
    
    ' Recopilando valores únicos de la Columna A y asociando valores de la Columna C
    For Each cell In wsSource.Range("A2:A" & lastRow)
        If Not uniqueValues.Exists(cell.value) Then
            uniqueValues.Add cell.value, wsSource.Cells(cell.Row, "C").value ' Asociamos el valor de la columna C
        End If
    Next cell
    
    ' Preparando encabezados en la hoja de destino
    With wsDest
        .Cells(1, 1).value = "Work Order" ' Estableciendo el primer encabezado de columna
        .Cells(1, 2).value = "Type" ' Nuevo encabezado para el tipo asociado
        For i = 1 To 12
            .Cells(1, i * 2 + 1).value = "WO Status " & i
            .Cells(1, i * 2 + 2).value = "Status Date " & i
        Next i
    End With

    ' Bucle a través de cada orden de trabajo única
    destRow = 2
    For Each key In uniqueValues
        wsDest.Cells(destRow, 1).value = key ' Escribe el valor único en la primera columna
        wsDest.Cells(destRow, 2).value = uniqueValues(key) ' Escribe el tipo asociado en la segunda columna
        j = 0 ' Inicializar desplazamiento de columna para la hoja de destino
        
        ' Búsqueda de filas con el valor de la clave actual y recopilar datos relacionados
        Set findRange = wsSource.Range("A1:A" & lastRow).Find(what:=key, LookIn:=xlValues, LookAt:=xlWhole)
        If Not findRange Is Nothing Then
            firstAddress = findRange.Address
            Do
                j = j + 1
                wsDest.Cells(destRow, j * 2 + 1).value = wsSource.Cells(findRange.Row, "E").value ' Copiar fecha
                wsDest.Cells(destRow, j * 2 + 2).value = wsSource.Cells(findRange.Row, "F").value ' Copiar valor asociado
                ' Intentar encontrar la próxima ocurrencia
                Set findRange = wsSource.Range("A1:A" & lastRow).FindNext(findRange)
                ' Condiciones de salida
                If j >= 12 Or findRange Is Nothing Or findRange.Address = firstAddress Then Exit Do
            Loop
        End If
        
        destRow = destRow + 1 ' Mover a la siguiente fila para el siguiente valor único
    Next key

    ' Definir formato de fecha en columnas con fechas
    Range("D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T,V:V,X:X,Z:Z").Select
    Selection.NumberFormat = "[$-en-US]d-mmm-yy;@"
    
    ' Variables adicionales para el rango de la tabla y la tabla en sí
    Dim tblRange As Range
    Dim ListObj As ListObject
    Dim LastCol As Long

    ' Encontramos la última fila con datos en la hoja "Consolidated"
    lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row

    ' Encontramos la última columna con datos en la hoja "Consolidated"
    LastCol = wsDest.Cells(1, wsDest.Columns.Count).End(xlToLeft).Column

    ' Estableciendo el rango para la nueva tabla basada en los datos
    Set tblRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(lastRow, LastCol))

    ' Creando la tabla en el rango especificado
    Set ListObj = wsDest.ListObjects.Add(xlSrcRange, tblRange, , xlYes)

    ' Opcionalmente, asignar un nombre a la tabla
    ListObj.Name = "Table_Consolidated"

    ' Estableciendo el estilo de tabla por defecto (cambiar según necesidad)
    ListObj.TableStyle = "TableStyleLight9"

End Sub

Answer 1

Option Explicit

Sub Demo()
    Dim oDicSta As Object, oDicDate As Object, rngData As Range
    Dim i As Long, iR As Long, sKey, ColCnt As Long
    Dim arrData, arrRes(), j As Long, aTxt
    Set oDicSta = CreateObject("scripting.dictionary")
    Set oDicDate = CreateObject("scripting.dictionary")
    Set rngData = Range("A1").CurrentRegion
    ' sort table
    rngData.Sort key1:=rngData.Columns(1), key2:=rngData.Columns(6), Header:=xlYes
    ' load data into array
    arrData = rngData.Value
    ' load group data into Dict
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 1) & "|" & arrData(i, 3)
        If Not oDicSta.exists(sKey) Then
            Set oDicSta(sKey) = New Collection
            Set oDicDate(sKey) = New Collection
        End If
        oDicSta(sKey).Add arrData(i, 5)
        oDicDate(sKey).Add arrData(i, 6)
    Next i
    ' get the max count of status
    For Each sKey In oDicSta.Keys
        If oDicSta(sKey).Count > ColCnt Then
            ColCnt = oDicSta(sKey).Count
        End If
    Next
    ReDim arrRes(1 To oDicSta.Count + 1, 1 To ColCnt * 3 + 2)
    ' populate header
    arrRes(1, 1) = "WorkOrder": arrRes(1, 2) = "Type"
    For j = 1 To ColCnt
        arrRes(1, j * 3) = "WO Status " & j
        arrRes(1, j * 3 + 1) = "Status Date " & j
        If j < ColCnt Then arrRes(1, j * 3 + 2) = "Days bn Status"
    Next
    iR = 1
    ' populate output array
    For Each sKey In oDicSta.Keys
        aTxt = Split(sKey, "|")
        iR = iR + 1
        arrRes(iR, 1) = aTxt(0)
        arrRes(iR, 2) = aTxt(1)
        For j = 1 To oDicSta(sKey).Count
            Debug.Print oDicSta(sKey)(j), oDicDate(sKey)(j)
            arrRes(iR, j * 3) = oDicSta(sKey)(j)
            arrRes(iR, j * 3 + 1) = oDicDate(sKey)(j)
            If j < oDicSta(sKey).Count Then
                arrRes(iR, j * 3 + 2) = oDicDate(sKey)(j + 1) - oDicDate(sKey)(j) + 1
            End If
        Next
    Next
    ' write data to sheet
    Sheets.Add
    Range("A1").Resize(oDicSta.Count + 1, ColCnt * 3 + 2) = arrRes
End Sub