Sub CombineAndRemoveDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim key As Variant
    Dim combinedDataDict As Object
    Dim inputData As Variant
    
    ' Set the worksheet
    Set ws = ActiveSheet
    
    ' Set the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Read the entire range into an array for efficiency
    inputData = ws.Range("A1:P" & lastRow).Value
    
    ' Create a dictionary to store combined data for each unique value in column A
    Set dict = CreateObject("Scripting.Dictionary")
    ' Create a dictionary to store combined data in column 9 for each unique value in column A
    Set combinedDataDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through the rows
    For i = 1 To lastRow
        ' Check if the value in column A is already in the main dictionary
        If dict.Exists(inputData(i, 1)) Then
            ' If duplicate, combine the value from column 9
            combinedDataDict(inputData(i, 1)) = combinedDataDict(inputData(i, 1)) & " | " & CStr(inputData(i, 9))
        Else
            ' If not a duplicate, add to the main dictionary with the entire row
            dict.Add inputData(i, 1), Join(Application.index(inputData, i, 0), ", ")
            ' Initialize the combined data for column 9
            combinedDataDict(inputData(i, 1)) = CStr(inputData(i, 9))
        End If
    Next i
    
    ' Clear the existing data in the worksheet
    ws.Cells.Clear
    
    ' Output the unique values and combined data to the worksheet
    Dim outputData() As Variant
    ReDim outputData(1 To dict.Count, 1 To UBound(inputData, 2))

    Dim index As Long
    index = 1

    For Each key In dict.Keys
        ' Split the string back into an array
        Dim rowData As Variant
        rowData = Split(dict(key), ", ")
        
        ' Copy columns
        For j = 1 To UBound(inputData, 2)
            ' If the current column is 9, use the combined data from the dictionary
            If j = 9 Then
                outputData(index, j) = combinedDataDict(key)
            Else
                outputData(index, j) = rowData(j - 1)
            End If
        Next j
        
        index = index + 1
    Next key

    ws.Cells(1, 1).Resize(dict.Count, UBound(inputData, 2)).Value = outputData

    ' Cleanup
    Set dict = Nothing
    Set combinedDataDict = Nothing
End Sub

字符串

• 将For i = 2更改为For i = 1以包含第一行
• Set ws = ActiveSheet操作活动工作表上的数据

Sub CombineAndRemoveDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim combinedData As String
    ' Set the worksheet
    Set ws = ActiveSheet ' **
    ' Set the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' Create a dictionary to store combined data for each unique value in column A
    Set dict = CreateObject("Scripting.Dictionary")
    ' Loop through the rows
    For i = 1 To lastRow ' **
        ' Check if the value in column A is already in the dictionary
        If dict.Exists(ws.Cells(i, 1).Value) Then
            ' If duplicate, combine the value from another column (let's say column B)
            combinedData = dict(ws.Cells(i, 1).Value) & " | " & ws.Cells(i, 2).Value
            dict(ws.Cells(i, 1).Value) = combinedData
        Else
            ' If not a duplicate, add to the dictionary with the original values from columns A and B
            dict.Add ws.Cells(i, 1).Value, ws.Cells(i, 2).Value
        End If
    Next i
    ' Clear the existing data in the worksheet
    ws.Cells.Clear
    ' Output the unique values and combined data to the worksheet
    ws.Cells(1, 1).Resize(dict.Count, 1).Value = Application.WorksheetFunction.Transpose(dict.Keys)
    ws.Cells(1, 2).Resize(dict.Count, 1).Value = Application.WorksheetFunction.Transpose(dict.Items)
    ' Cleanup
    Set dict = Nothing
End Sub

字符串

• 更新：*

问：我有A到P列，我想保留A到H列和J到P列中的所有内容，但合并A列中重复的I列

Option Explicit

Sub CombineAndRemoveDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim combinedData As String
    Dim arrData, arrRes()
    Const MERGE_COL = 9 '  column I
    Const COL_CNT = 16 '  column A:P
    ' Set the worksheet
    Set ws = ActiveSheet ' **
    ' Set the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    arrData = ws.Range("A1", ws.Cells(lastRow, MERGE_COL)).Value
    ReDim arrRes(1 To lastRow, 0)
    ' Create a dictionary to store combined data for each unique value in column A
    Set dict = CreateObject("Scripting.Dictionary")
    ' Loop through the rows
    For i = 1 To lastRow ' **
        ' Check if the value in column A is already in the dictionary
        If dict.Exists(arrData(i, 1)) Then
            ' If duplicate, combine the value from MERGE_COL
            combinedData = dict(arrData(i, 1)) & " | " & arrData(i, MERGE_COL)
            dict(arrData(i, 1)) = combinedData
        Else
            ' If not a duplicate, add to the dictionary with the original values from columns A and MERGE_COL
            dict.Add arrData(i, 1), arrData(i, MERGE_COL)
        End If
    Next i
    ' Update MERGE_COL ( col I )
    For i = 1 To lastRow ' **
        arrRes(i, 0) = dict(arrData(i, 1))
    Next
    ' Output the unique values and combined data to the worksheet
    ws.Cells(1, MERGE_COL).Resize(lastRow, 1).Value = arrRes
    ws.Range("A1", ws.Cells(lastRow, COL_CNT)).RemoveDuplicates _
        Columns:=Array(1, MERGE_COL), Header:=xlNo
    ' Cleanup
    Set dict = Nothing
End Sub

型

的数据