Excel VBA合并来自多行的数据
我有一个非常大的XLS信息分布在多行，看起来像：
TopName Name Mode Item1 Item2 Item3 Item4 ----------------------------------------------------- Foo Name1 ModeX x() Foo Name2 ModeY x() Foo Name1 ModeX y() Foo Name1 ModeX y() Foo Name2 ModeY y() 我现在想要做的是将基于名称的数据合并到新的工作表或Excel文件。 输出表应该看起来像这样
Name Mode Item1 Item2 Item3 Item4 ------------------------------------------- Name1 ModeX x() y() y() Name2 ModeY y() x()
我自己会尝试通过VBA提出一个解决scheme，但肯定有人在这方面更好，可以发布一个简单的解决scheme？
更新：我尝试了以下，但它根本不工作：
Sub ConsolidateRows() 'takes rows and consolidate one or many cells, based on one or many cells matching with above or below rows. Dim lastRow As Long, i As Long, j As Long Dim colMatch As Variant, colConcat As Variant '**********PARAMETERS TO UPDATE**************** Const strMatch As String = "B" 'columns that need to match for consolidation, separated by commas Const strConcat As String = "C,D,F,H,I,J,K,L,M,N,O,P,Q,R,S,T,U" 'columns that need consolidating, separated by commas Const strSep As String = ", " 'string that will separate the consolidated values '*************END PARAMETERS******************* Application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes colMatch = Split(strMatch, ",") colConcat = Split(strConcat, ",") lastRow = Range("B" & Rows.Count).End(xlUp).Row 'get last row For i = lastRow To 4 Step -1 'loop from last Row to one For j = 0 To UBound(colMatch) If Cells(i, colMatch(j)) <> Cells(i - 1, colMatch(j)) Then GoTo nxti Next For j = 0 To UBound(colConcat) Cells(i - 1, colConcat(j)) = Cells(i - 1, colConcat(j)) & strSep & Cells(i, colConcat(j)) Next Rows(i).Delete nxti: Next Application.ScreenUpdating = True 'reenable ScreenUpdating End Sub
更新2：好的，该文件甚至没有连续的行中的两个匹配值，因此，上面的代码可以显然不工作:(我需要的是某种字典或东西…
与您的任务和示例Excel工作表数据相关如下所示：
TopName Name Mode Item1 Item2 Item3 Item4 Foo Name1 ModeX x() Foo Name2 ModeY x() Foo Name1 ModeX y() Foo Name1 ModeX y() Foo Name2 ModeY y()
您可以使用以下Excel VBA代码片段：
Sub ConsolidateRowsData() Dim lastRow As Long, i As Long, j As Long, k As Long Application.ScreenUpdating = False 'disable ScreenUpdating lastRow = Range("B" & Rows.Count).End(xlUp).Row 'get last row 'concatenate Item data For i = 3 To lastRow 'outer loop thru data rows (starting w/row 3) For j = i + 1 To lastRow 'inner loop thru data rows If Cells(i, 2) = Cells(j, 2) Then For k = 4 To 7 'loop thru columns: Item1...Item4 If (Cells(i, k) = "" And Cells(j, k) <> "") Then Cells(i, k) = Cells(j, k) End If Next End If Next Next 'delete duplicates For i = 3 To lastRow 'outer loop thru data rows For j = lastRow To i + 1 Step -1 'inner loop thru data rows If Cells(i, 2) = Cells(j, 2) Then Rows(j).Delete End If Next Next Application.ScreenUpdating = True 'reenable ScreenUpdating End Sub
即使它没有为速度优化，但会做这项工作。 希望这会有所帮助。 最好的祝福，