如何使用 VBA 展平 Excel 中数据在行之间拆分的表格？

Question

我目前在 Excel 中有一个原始数据表，其中汇总了给定参与的阶段 A、B 和 C 的状态。某些参与可能没有所有 3 个阶段的数据。

Row| EngagementID | A_date | A_status | B_date | B_status | C_date | C_status
1  |      201     |   2/2  | Approved |        |          |        |          
2  |      201     |        |          |  3/5   | Approved |        |          
3  |      201     |        |          |        |          |  4/1   |  Pending  
4  |      203     |   2/12 | Submitted|        |          |        |          
5  |      203     |        |          |  2/20  | Approved |        |          
6  |      207     |   2/5  | Approved |        |          |        |          

我正在尝试将表格展平，使其看起来像这样：

Row| EngagementID | A_date | A_status | B_date | B_status | C_date | C_status
1  |      201     |   2/2  | Approved |  3/5   | Approved |  4/1   |  Pending 
2  |      203     |   2/12 | Submitted|  2/20  | Approved |        |         
3  |      207     |   2/5  | Approved |        |          |        |          

---

问题：多个实例

但是，在某些情况下，同一个 EngagementID 有多个实例。例如，它可能有以下内容：

    Row| EngagementID | A_date | A_status | B_date | B_status | C_date | C_status
    1  |      201     |   2/2  | Approved |        |          |        |          
    2  |      201     |        |          |  3/5   | Approved |        |          
    3  |      201     |        |          |  3/18  | Pending  |        |           
    4  |      201     |        |          |        |          |  5/20  |  Pending  
    5  |      201     |        |          |        |          |  5/15  |  Submitted

我正在尝试使 VBA 足够灵活，以便在这些情况下，表格将转换为

Row| EngagementID | A_date | A_status | B_date | B_status | C_date | C_status
1  |      201     |   2/2  | Approved |  3/5   | Approved |  5/20  |  Pending 
2  |      201     |   2/2  | Approved |  3/18  | Pending  |  5/15  |  Submitted

我可以使用以下 VBA 代码解决单实例方面的问题：

Private Sub test()
Dim R As Long
Dim i As Integer
i = 1
R = 2
Count = 0
Do While Not IsEmpty(Range("A" & R))
    If Cells(R, 1).Value = Cells(R + 1, 1).Value Then
        Count = Count + 1
    Else
        i = 1
        Do While i <= Count
            Cells(R - Count, 2 + (2 * i)).Value = Cells(R - Count + i, 2 + (2 * i))
            Cells(R - Count, 3 + (2 * i)).Value = Cells(R - Count + i, 3 + (2 * i))
            i = i + 1
        Loop
            i = 1
            Do While i <= Count
                Rows(R - Count + i).Delete
                i = i + 1
                R = R - 1
            Loop
        Count = 0
    End If
R = R + 1
Loop

End Sub

但是，这不考虑多个实例。 任何关于我可以在哪里调整 VBA 以适应这种“多实例”场景的想法将不胜感激。谢谢！

Answer 1

您可以使用 Power Query 轻松处理此问题。它是您可以免费获得并在 Excel 2010+ 中激活的插件（默认情况下，在 Excel 2016 中称为 Get & Transform）。在那里，您可以直接连接您的源并根据需要编辑您的数据。对于您的特定情况，请按照以下步骤操作：

Answer 2

已编辑

Option Explicit

Sub test()

Dim i As Long               ' loop
Dim iRow As Long            ' actual row to process
Dim i1stEmpy As Long        ' 1st empty cell
Dim iBlkStart As Long       ' this block starts here

Const colEngID = 2
Const colAdate = colEngID + 1
Const colAstat = colAdate + 1
Const colBdate = colAstat + 1
Const colBstat = colBdate + 1
Const colCdate = colBstat + 1
Const colCstat = colCdate + 1

iRow = 2        ' skip header row
Do While Trim$(Cells(iRow, 1)) <> vbNullString
    iBlkStart = iRow        ' 1st row of block of the same engagement
    For i = 0 To 2
        iRow = iBlkStart
        i1stEmpy = 0           ' next data comes here
        Do While Cells(iRow, colEngID) = Cells(iBlkStart, colEngID)
            If Trim$(Cells(iRow, colAdate + 2 * i)) = vbNullString Then
               If i1stEmpy = 0 Then i1stEmpy = iRow        ' set 1st empty cell
            Else
                If iRow <> iBlkStart And iRow <> i1stEmpy And i1stEmpy > 0 Then ' some data found
                    Cells(i1stEmpy, colAdate + 2 * i) = Cells(iRow, colAdate + 2 * i)  ' copy cell from below
                    Cells(i1stEmpy, colAstat + 2 * i) = Cells(iRow, colAstat + 2 * i)  ' copy cell from below
                    Cells(iRow, colAdate + 2 * i).Clear  ' clear cell
                    Cells(iRow, colAstat + 2 * i).Clear  ' clear cell
                    i1stEmpy = i1stEmpy + 1         ' set to next empty
                End If
            End If
            iRow = iRow + 1
        Loop
    Next i
    ' delete empty rows
    iRow = iBlkStart
    Do While Cells(iRow, colEngID) = Cells(iBlkStart, colEngID)
        If Trim$(Cells(iRow, colAdate)) = vbNullString And Trim$(Cells(iRow, colBdate)) = vbNullString And Trim$(Cells(iRow, colCdate)) = vbNullString Then    ' all cells are empty
            Cells(iRow, 1).EntireRow.Delete
        Else
            iRow = iRow + 1
        End If
    Loop
Loop ' irow

End Sub