Question

我在这些方面搜索了一些东西，但找不到任何完全符合我要求的答案。我所拥有的服装项目电子表格按大小分割。例如：

Product Name  |  Image      |  Color  |  Size  
_______________________________________________
tshirt        |  tshirt.jpg |  White  |  Small
tshirt        |  tshirt.jpg |  White  |  Medium
tshirt        |  tshirt.jpg |  White  |  Large
polo          |  polo.jpg   |  Blue   |  Small
polo          |  polo.jpg   |  Blue   |  Medium
polo          |  polo.jpg   |  Blue   |  Large
...

我希望发生的事情是将同一项目的所有尺寸压缩为一行，如下所示：

Product Name  |  Image      |  Color  |  Size  
_______________________________________________
tshirt        |  tshirt.jpg |  White  |  Small Medium Large
polo          |  polo.jpg   |  Blue   |  Small Medium Large
...

我找到了这个脚本，但它只删除了行，并没有将大小合并到一个单元格中：

Sub removeDups()

Dim myRow As Long
Dim sTRef As String

sTRef = Cells(2, 2)

myRow = 1
Do While (Cells(myRow, 2) <> "")

If (sTRef <> Cells(myRow, 2)) Then
sTRef = Cells(myRow, 2)
myRow = myRow + 1

Else

Rows(myRow).Select
Selection.Delete Shift:=xlUp

End If
Loop
End Sub

如何在删除行之前修改此脚本以合并大小？

Answer 1

使用此代码（我认为您的尺寸在“E”栏中）：

Sub removeDups()

    Dim myRow As Long
    Dim sTRef As String

    sTRef = Cells(2, 2)

    myRow = 3
    Do While Cells(myRow, 2) <> ""

        If sTRef <> Cells(myRow, 2) Then
            sTRef = Cells(myRow, 2)
            myRow = myRow + 1
        Else
            Cells(myRow - 1, "E") = Cells(myRow - 1, "E") & " " & Cells(myRow, "E")
            Rows(myRow).Delete Shift:=xlUp
        End If
    Loop

End Sub

Answer 2

simoco的答案可以更加通用，如下所示：

数据集：

╔══════════════╦════════════╦═══════╦════════╦════════════════╗
║ Product Name ║   Image    ║ Color ║  Size  ║     E-mail     ║
╠══════════════╬════════════╬═══════╬════════╬════════════════╣
║ tshirt       ║ tshirt.jpg ║ White ║ Small  ║ john@gmail.com ║
║ tshirt       ║ tshirt.jpg ║ White ║ Medium ║ bob@gmail.com  ║
║ tshirt       ║ tshirt.jpg ║ White ║ Large  ║ bob@gmail.com  ║
║ polo         ║ polo.jpg   ║ Blue  ║ Small  ║ bob@gmail.com  ║
║ yolo         ║            ║ Blue  ║ Medium ║ jack@gmail.com ║
║ holo         ║            ║ Blue  ║ Large  ║ jack@gmail.com ║
║ rolo         ║ polo.jpg   ║       ║ Small  ║ jack@gmail.com ║
║ yolo         ║ polo.jpg   ║ Blue  ║ Medium ║ joe@gmail.com  ║
║ holo         ║            ║ Blue  ║ Large  ║ joe@gmail.com  ║
║ rolo         ║            ║       ║ Small  ║ joe@gmail.com  ║
╚══════════════╩════════════╩═══════╩════════╩════════════════╝

假设：

让列E包含您想要合并为一个的值。
设5为工作表中存在的列数。
让我们合并所有其他不相等的列中的所有单元格。
让我们引入％符号，以便我们可以使用条件格式来查找已合并数据的所有单元格。
让我们考虑空单元格。

结果代码是：

Sub removeDups()
    Dim myRow As Long
    Dim sTRef As String
    sTRef = Cells(2, "E")
    myRow = 3
    Do While Cells(myRow, "E") <> ""
        If sTRef <> Cells(myRow, "E") Then
            sTRef = Cells(myRow, "E")
            myRow = myRow + 1
        Else
            For i = 1 To 5
                If Cells(myRow - 1, i) = "" Then
                    Cells(myRow - 1, i) = Cells(myRow, i)
                Else
                        If Cells(myRow, i) = Cells(myRow - 1, i) Then
                            Cells(myRow - 1, i) = Cells(myRow, i)
                        Else
                            If Cells(myRow, i) <> "" Then
                                Cells(myRow - 1, i) = Cells(myRow - 1, i) & " % " & Cells(myRow, i)
                            End If
                        End If
                End If
            Next i
            Rows(myRow).Delete Shift:=xlUp
        End If
    Loop
End Sub

simoco，谢谢你！

Answer 3

我的解决方案假设除了要合并的值的列之外，每个列都必须相同。

将代码放在链接到您正在处理的工作表的VBA模块中。在您的示例中，它假定要对表进行排序。

Const MergeCol = 4

Sub MergeRows()
    Dim Row As Long
    Dim Col As Long
    Dim Equal As Boolean

    With Me.UsedRange
        For Row = 3 To .Rows.Count
            If Not IsEmpty(.Cells(Row, 1)) Then
                Equal = True
                For Col = 1 To .Columns.Count
                    If Col <> MergeCol Then
                        If .Cells(Row - 1, Col).Value <> .Cells(Row, Col).Value Then
                            Equal = False
                            Exit For
                        End If
                    End If
                Next Col
                If Equal Then
                    ' Merge
                    With .Cells(Row - 1, MergeCol)
                        .Value = .Value & ", " & Me.Cells(Row, MergeCol).Value
                    End With
                    .Rows(Row).Delete
                    Row = Row - 1
                End If
            End If
        Next
    End With
End Sub

如果特定列中的单元格相同，则在Excel中合并和删除行

3 个答案: