将 A 列中的每个唯一值与重复值合并到一个新工作表中

Question

我需要将 A 列中具有重复值的每个唯一值合并到一个新工作表中。该值是重复的，因为每次 A 列中的记录更改状态时，它都会创建一个新行，并在 F 列中包含新的状态和更改日期。

我需要将每个唯一值的所有这些数据合并到一行中。我已经尝试过，但我不知道这是否是最好的方法。另外，我无法计算 F 列中每个状态更改之间的天数，也没有让他将它们从最旧的状态排序到最新的状态。

我给您留下了我的工作表示例，其中包含一个唯一值和我设法运行的代码。

我尝试得到的结果：

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