如何使用VBA在Excel中展平表格，其中数据在行之间分割？

Posted 2021-05-03

我目前在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以适应这种“多实例”场景的任何想法都将非常感激。谢谢！

答案

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

另一答案

EDITED

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