您可以在Power Query中使用Table.Group方法和自定义聚合来完成此操作。

• 根据您在问题中的评论，我假设您不想保留原始的Color列（仅第一行），但如果不是这样，也可以轻松地添加回去。*

使用增强查询的步骤

• 选择数据表中的某个单元格
• 第一个月
• PQ编辑器打开时：Home => Advanced Editor
• 记录第2行中的表名称
• 将下面的M代码粘贴到您看到的位置
• 将第2行中的Table名称改回最初生成的名称。
• 阅读评论并探索Applied Steps以了解算法
• • M代码**

let

//Change next line to reflect actual data source
    Source = Excel.CurrentWorkbook(){[Name="Table17"]}[Content],

//set data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Cod", type text}, {"Name", type text}, {"Color", type text}}),

//Group by Cod amd Name, then aggregate by combining the colors
    #"Grouped Rows" = Table.Group(#"Changed Type", {"Cod","Name"}, {
        {"Colors", each Text.Combine(List.Distinct(_[Color]),";")}})
in
    #"Grouped Rows"

请使用下一个代码，它使用字典（从数组中加载）来提取唯一代码，然后处理其内容：

Sub CondenseFruitsTable()
  Dim sh As Worksheet, lastR As Long, arr, arrFin, mtch, dict As Object, i As Long
  
  Set sh = ActiveSheet 'use here the sheet you need
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row on column A:A
 
  arr = sh.Range("A1:C" & lastR).Value2 'place the range in an array for faster iteration/processing
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(arr)
    If Not dict.Exists(arr(i, 1)) Then
        dict(arr(i, 1)) = arr(i, 2) & "|" & arr(i, 3)
    Else
        mtch = Application.match(arr(i, 3), Split(Split(dict(arr(i, 1)), "|")(1), ";"), 0)
        If IsError(mtch) Then 'if the color does  not already exist:
            dict(arr(i, 1)) = dict(arr(i, 1)) & ";" & arr(i, 3)
        End If
    End If
  Next i
  
  'redim the final array to also include the header:
  ReDim arrFin(1 To dict.count + 1, 1 To 3)
  
  arrFin(1, 1) = arr(1, 1): arrFin(1, 2) = arr(1, 2): arrFin(1, 3) = arr(1, 3)
  For i = 0 To dict.count - 1
        arrFin(i + 2, 1) = CStr(dict.keys()(i))
        arrFin(i + 2, 2) = Split(dict.Items()(i), "|")(0)
        arrFin(i + 2, 3) = Split(dict.Items()(i), "|")(1)
  Next i
  'drop the result and format a little:
  With sh.Range("F1").Resize(UBound(arrFin), 3)
        .Columns(1).NumberFormat = "@"
        .Value2 = arrFin
        .EntireColumn.AutoFit
  End With
End Sub

唯一化表格数据

Sub UniquifyTable()
    
    ' Define constants.
    Const UNI_COL As Long = 1 ' or 2
    Const JOIN_COL As Long = 3
    Const JOIN_DELIMITER As String = "; "
    Const NEW_COLUMN_TITLE As String = "Color (sep. Semicolon)"

    With ActiveSheet.Range("A1").CurrentRegion
        
        ' Unique to dictionary.
        
        Dim Data: Data = .Columns(UNI_COL).Value
        Dim uDict As Object: Set uDict = CreateObject("Scripting.Dictionary")
        uDict.CompareMode = vbTextCompare
        Dim srCount As Long: srCount = .Rows.Count
        
        Dim r As Long
        
        For r = 2 To srCount ' skip headers
            If Not uDict.Exists(Data(r, UNI_COL)) Then
                Set uDict(Data(r, UNI_COL)) = New Collection
            End If
            uDict(Data(r, UNI_COL)).Add r
        Next r
        
        ' Source to array.
        
        Dim scCount As Long: scCount = .Columns.Count
        Data = .Value
        
        ' Overwrite array with results.
        
        ' Resize (add column).
        ReDim Preserve Data(1 To srCount, 1 To scCount + 1)
        Data(1, scCount + 1) = NEW_COLUMN_TITLE
        
        Dim jDict As Object: Set jDict = CreateObject("Scripting.Dictionary")
        jDict.CompareMode = vbTextCompare
        
        Dim Key, Item, c As Long, IsNewRow As Boolean
        r = 1 ' skip headers
        
        ' Populate top.
        For Each Key In uDict.Keys
            r = r + 1
            For Each Item In uDict(Key)
                If jDict.Count = 0 Then
                    For c = 1 To scCount
                        Data(r, c) = Data(Item, c)
                    Next c
                End If
                If Not jDict.Exists(Data(Item, JOIN_COL)) Then
                    jDict(Data(Item, JOIN_COL)) = Empty
                End If
            Next Item
            Data(r, c) = Join(jDict.Keys, JOIN_DELIMITER)
            jDict.RemoveAll ' reset for next iteration
        Next Key
        
        ' Clear bottom.
        For r = r + 1 To srCount
            For c = 1 To scCount
                Data(r, c) = Empty
            Next c
        Next r
        
        ' Write back to worksheet.
        
        .Resize(, c).Value = Data
        .Columns(c).AutoFit
        
    End With

End Sub