Excel VBA - 合并重复列数据

Question

我有一个需要整合的标准主电子表格，但不确定如何自动执行此操作。

数据如下：

Unique ID | Info | Info 2 | Info 3 | Criteria 1 | Info for Criteria 1 | Criteria 2 | Info for Criteria 2
1234      | ABC  | 1/1/20 | Active | Plan 1     | 1/1/2020            | Plan 2     | 3/15/2020
4567      | DEF  | 2/1/20 | Active | Plan 1     | 1/5/2020            | Plan 2     | 2/15/2020
9874      | HJD  | 2/1/20 | Active | Plan 1     | 3/5/2020            |            | 

And I need it to look like this:

Unique ID | Info | Info 2 | Info 3 | Criteria 1 | Info for Criteria 1 
1234      | ABC  | 1/1/20 | Active | Plan 1     | 1/1/2020            
1234      | ABC  | 1/1/20 | Active | Plan 2     | 3/15/2020          
4567      | DEF  | 2/1/20 | Active | Plan 1     | 1/5/2020            
4567      | DEF  | 2/1/20 | Active | Plan 2     | 2/15/2020           
9874      | HJD  | 2/1/20 | Active | Plan 1     | 3/5/2020            

条件和特定于条件的信息列在列之间重复，我需要将所有信息堆叠成行，第一组数据（第 1 到 4 列）重复。

我不知道自动化此过程的最有效方法是什么。目前，它有很多复制和粘贴。我想编写一个宏来遍历重复条件并复制信息并将其粘贴到数据的底部。该表始终采用相同的格式，具有相同数量的重复条件 (27)。

任何朝着正确方向的推动都会非常感激。

Answer 1

使用此宏更改宏中的工作表和工作簿名称。请在使用宏之前备份您的数据，因为如果您不喜欢结果，那么它不会使用撤消来反转。

Private Sub combine()
Dim lastdata As Long
Dim wb As Workbook
Dim ws1 As Worksheet
Dim i As Long
lastdata = Cells(Rows.Count, 1).End(xlUp).Row
Set wb = Workbooks("book1.xlsm") 'Change Workbook Name
Set ws1 = wb.Worksheets("sheet1") 'Change Worksheet Name
For i = lastdata To 2 Step -1
If ws1.Cells(i, Columns.Count).End(xlToLeft).Column > 6 Then
ws1.Rows(i).Insert
ws1.Cells(i + 1, 1).Resize(1, 4).Copy Destination:=Cells(i, 1)
ws1.Cells(i + 1, 7).Resize(1, 2).Cut Destination:=Cells(i, 5)
End If
Next i
End Sub