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
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