excel 合并ID重复的记录并合并不同的数据

bzzcjhmw 于 2022-12-30 发布在其他

关注(0)|答案(2)|浏览(241)

以下是我的工作表中的数据样本。它已在B列中按从小到大的顺序排序，以显示重复的项目代码（突出显示为黄色）：

以下是对以下列的细分：

A列-ID，每个ID都是唯一的
B列-项目代码，出现重复
列C到E-不同数据的范围，但如果两个记录具有相同的项目代码（B），则其余数据（C到E）将保持不变，如上所示
列F至L-周数（一年中为52，因此K列中为1）包含数值。尽管多个记录可以具有相同的项目代码（B），但列可以包含不同的数值（请注意上面屏幕截图中的红色标记）

我希望根据找到的重复项目代码（B）合并这些记录，从而存储第一个ID值（A），合并列C到E，并组合列F到L。下面的屏幕截图显示了我所需的输出。

如您所见，记录已组合和合并。带有红色标记的记录表示，当有两个或多个记录具有相同的项目代码，但在同一列中具有多个数值时，这些数值是如何相加在一起以显示新值的。如果只有一个值，则将其与其余值合并，以便为每个项目代码创建一行。
我在网上找了很长时间，我所能找到的就是使用合并和VBA代码将这些记录合并成一种格式，这种格式不会导致这种预期的输出，包括使用公式。
谢谢大家!
编辑：以上问题已经得到了回答。然而，下面是我的原始数据，我认为上述问题的解决方案可以很容易地调整并应用到原始数据中，但我发现以下代码没有运气：

Sub ConsolidateItemCodes()

   Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
   Dim i As Long, j As Long, k As Long, dict As Object
   
   Set sh = Sheets("Sample of Original Data") 'use here the sheet you need processing
   Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
   
   lastR = sh.Range("F" & sh.Rows.Count).End(xlUp).Row
   arrH = sh.Range("A1:CO1").Value2           'the headers
   arr = sh.Range("A2:CO" & lastR).Value2  'place the range in an array for faster iteration/processing
   ReDim arrVal(0 To 36) 'redim the array keeping the values
    
   'load the dictionary (ItemCodes as unique keys):
   Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 6)) Then
            For j = 0 To 36: arrVal(j) = arr(i, j + 36): Next j
            dict.Add arr(i, 6), Array(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15), arr(i, 16), arr(i, 17), arr(i, 18), arr(i, 19), arr(i, 20), arr(i, 21), arr(i, 22), arr(i, 23), arr(i, 24), arr(i, 25), arr(i, 26), arr(i, 27), arr(i, 28), arr(i, 29), arr(i, 30), arr(i, 31), arr(i, 32), arr(i, 33), arr(i, 34), arr(i, 35)), arrVal)
        Else
            arrIt = dict(arr(i, 6))  'a dictionary item can be adaptet directly, EXCEPT arrays...
            For j = 0 To 36
                arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 36)
            Next j
            dict(arr(i, 6)) = arrIt 'place back the updated jagged array
        End If
   Next i
 
   'process dictionary content
   ReDim arrfin(1 To dict.Count + 1, 1 To UBound(arr, 6))
   
   'place the header in the final array:
   For i = 1 To UBound(arrH, 6): arrfin(1, i) = arrH(1, i): Next i
   
   'extract data from dictionary:
   k = 1
   For j = 0 To dict.Count - 1
        k = k + 1
        arrIt = dict.Items()(j)
        arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = arrIt(0)(1): arrfin(k, 3) = arrIt(0)(2): arrfin(k, 4) = arrIt(0)(3): arrfin(k, 5) = arrIt(0)(4): arrfin(k, 6) = dict.keys()(j)
        arrfin(k, 7) = arrIt(0)(5): arrfin(k, 8) = arrIt(0)(6): arrfin(k, 9) = arrIt(0)(7): arrfin(k, 10) = arrIt(0)(8): arrfin(k, 11) = arrIt(0)(9): arrfin(k, 12) = arrIt(0)(10): arrfin(k, 13) = arrIt(0)(11): arrfin(k, 14) = arrIt(0)(12): arrfin(k, 15) = arrIt(0)(13): arrfin(k, 16) = arrIt(0)(14): arrfin(k, 17) = arrIt(0)(15): arrfin(k, 18) = arrIt(0)(16): arrfin(k, 19) = arrIt(0)(17): arrfin(k, 20) = arrIt(0)(18): arrfin(k, 21) = arrIt(0)(19): arrfin(k, 22) = arrIt(0)(20): arrfin(k, 23) = arrIt(0)(21): arrfin(k, 24) = arrIt(0)(22): arrfin(k, 25) = arrIt(0)(23): arrfin(k, 26) = arrIt(0)(24): arrfin(k, 27) = arrIt(0)(25): arrfin(k, 28) = arrIt(0)(26): arrfin(k, 29) = arrIt(0)(27): arrfin(k, 30) = arrIt(0)(28): arrfin(k, 31) = arrIt(0)(29): arrfin(k, 32) = arrIt(0)(30): arrfin(k, 33) = arrIt(0)(31): arrfin(k, 34) = arrIt(0)(32): arrfin(k, 35) = arrIt(0)(33)
        For i = 0 To 36: arrfin(k, i + 36) = arrIt(1)(i): Next i
   Next j
   
   'drop the processed array content at once:
   With destSh.Range("A1").Resize(k, UBound(arrfin, 6))
        .Value2 = arrfin
        .Rows(1).Font.Bold = True
        .EntireColumn.AutoFit
    End With
    
    MsgBox "Ready..."
End Sub

这是我的原始数据的一个片段，正如你所看到的，A列是相同的，上面的B（2）列实际上是F（6）列，F（6）列实际上是AJ（36）列，它在CO（93）列结束。

而这就是我想要的输出，类似于上面的。

excel

来源：https://stackoverflow.com/questions/74949610/merge-records-with-duplicate-id-and-combine-different-data

2条答案

按热度按时间

6jjcrrmo1#

请测试下一个代码。它在下一个工作表中返回（现在）与处理过的工作表相比较，但是你可以根据需要设置目标工作表。正如我在上面的评论中所说的，它使用数组和字典，应该非常快。记录可以按任何顺序排列：

Sub ConsolidateItemCodes()
   Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
   Dim i As Long, j As Long, k As Long, dict As Object
   
   Set sh = ActiveSheet 'use here the sheet you need processing
   Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
   
   If sh.FilterMode Then sh.ShowAllData 'to show all data in case of filters...

   lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
   arrH = sh.Range("A1:L1").Value2           'the headers
   arr = sh.Range("A2:L" & lastR).Value2  'place the range in an array for faster iteration/processing
   ReDim arrVal(0 To 6) 'redim the array keeping the values
    
   'load the dictionary (ItemCodes as unique keys):
   Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 2)) Then
            For j = 0 To 6: arrVal(j) = arr(i, j + 6): Next j
            dict.Add arr(i, 2), Array(Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5)), arrVal)
        Else
            arrIt = dict(arr(i, 2))  'a dictionary item can be adaptet directly, EXCEPT arrays...
            For j = 0 To 6
                arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 6)
            Next j
            dict(arr(i, 2)) = arrIt 'place back the updated jagged array
        End If
   Next i
 
   'process dictionary content
   ReDim arrfin(1 To dict.count + 1, 1 To UBound(arr, 2))
   
   'place the header in the final array:
   For i = 1 To UBound(arrH, 2): arrfin(1, i) = arrH(1, i): Next i
   
   'extract data from dictionary:
   k = 1
   For j = 0 To dict.count - 1
        k = k + 1
        arrIt = dict.Items()(j)
        arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = dict.keys()(j)
        arrfin(k, 3) = arrIt(0)(1): arrfin(k, 4) = arrIt(0)(2): arrfin(k, 5) = arrIt(0)(3)
        For i = 0 To 6: arrfin(k, i + 6) = arrIt(1)(i): Next i
   Next j
   
   'drop the processed array content at once:
   With destSh.Range("A1").Resize(k, UBound(arrfin, 2))
        .Value2 = arrfin
        .rows(1).Font.Bold = True
        .EntireColumn.AutoFit
    End With
    
    MsgBox "Ready..."
End Sub

我试着注解所有的代码行，以使其易于理解。如果有些地方仍然不够清楚，请不要犹豫要求澄清。
请在测试后发送一些反馈。

赞(0）回复(0）举报 2022-12-30

6psbrbz92#

Option Explicit

Sub aggregate()

   Const ITEM_CODE = "F" ' Item Code
   Const WK1 = "AJ" ' start of numeric data

   Dim wb As Workbook, ws As Worksheet, n As Long, c1 As Long, c2 As Long
   Dim c As Long, r As Long, lastrow As Long

   Set wb = ThisWorkbook
   Set ws = wb.Sheets("Sheet1")
   
   Application.ScreenUpdating = False
   With ws
        lastrow = .Cells(.Rows.Count, ITEM_CODE).End(xlUp).Row
        ' start and end columns
        c1 = .Columns(WK1).Column
        c2 = .UsedRange.Columns.Count + .UsedRange.Column - 1
        
        ' scan up sheet
        For r = lastrow To 3 Step -1
            ' compare with row above
            If .Cells(r, ITEM_CODE) = .Cells(r - 1, ITEM_CODE) Then
                For c = c1 To c2
                    ' aggregate if not blank
                    If Cells(r, c) <> "" Then
                        .Cells(r - 1, c) = .Cells(r - 1, c) + .Cells(r, c)
                    End If
                Next
                '.Rows(r).Interior.ColorIndex = 3
                .Rows(r).Delete
                n = n + 1
            End If
        Next
   End With
   Application.ScreenUpdating = True
   MsgBox n & " rows deleted", vbInformation

End Sub

赞(0）回复(0）举报 2022-12-30

我来回答

excel 合并ID重复的记录并合并不同的数据

2条答案

相关问题

热门标签

最新问答