Excel VBA：如何查找重复项和转置？

Question

我想请您帮忙完成这项任务。

Excel工作表在ColumnA中包含重复的项目。 我想将这些重复项合并为一行 。 请看图片。

如实际图片所示， ColumnA有三个A。 对于每个A ，都有来自ColumnB的一些单元格。 可以说这些是A的值。每行的值分别用不同的颜色标记。

我想要将A的值合并为一行，如目标图片所示。

excel工作表已预先排序 ，因此ColumnA中的所有重复项始终一起出现。

请注意，还有一些项目没有重复项：ColumnA中只有一个E。 该行不需要转置。

还请注意，ColumnA中可能有更多重复项。 例如10x T s或30x K s。

为了简化任务，在转换后无需删除空白行。

颜色仅用于显示问题，excel工作表中没有颜色。

到目前为止，完成这项任务。

实际上，我之前曾问过类似的问题： Excel VBA：如何转换这种单元格？

链接中有一些非常好的代码，但是很遗憾，我无法重写此任务的代码。

所以请帮帮我〜

但是请不要忘记周末愉快〜

谢谢！

Answer 1

尝试下面的代码（“奖励”功能，还会删除空行）。 正如您在帖子中所写的那样，数据是根据列A排序的，并且数据中没有空行。

Sub TransposeDup()

Dim LastCol, LastColCpy             As Long
Dim lrow                            As Long

lrow = 1
While Cells(lrow, 1) <> ""
    If Cells(lrow, 1) = Cells(lrow + 1, 1) Then
        LastCol = Cells(lrow, Columns.Count).End(xlToLeft).Column
        LastColCpy = Cells(lrow + 1, Columns.Count).End(xlToLeft).Column
        Range(Cells(lrow + 1, 2), Cells(lrow + 1, LastColCpy)).Copy Destination:=Cells(lrow, LastCol + 1)
        Rows(lrow + 1).EntireRow.Delete
    Else
        lrow = lrow + 1
    End If
Wend

End Sub

Answer 2

如下所示的内容应该可以帮助您朝正确的方向发展。 这不会复制格式，但是会获取值。 您可以调整它以到达需要的位置：

Sub dedup_and_concat()
    Dim intWriteCol As Integer
    Dim intReadCol As Integer
    Dim intWriteRow As Integer
    Dim intReadRow As Integer
    Dim intStartRow As Integer
    Dim intEndRow As Integer
    Dim strPrevRowValue As String

    'Start and end rows:
    intStartRow = 1
    intEndRow = 8

    'initial values:
    intWriteRow = 1

    'Loop from your start row to your end row
    For intReadRow = intStartRow To intEndRow 'beginning and ending rows
        intReadCol = 2

        'If we are at the first row, then just capture values
        'Also if this is a new value, then reset all of the write variables
        If intReadRow = intStartRow Or Sheet1.Cells(intReadRow, 1).Value <> Sheet1.Cells(intWriteRow, 1).Value Then

            'set the row and initial column we are writing to
            intWriteRow = intReadRow
            intWriteCol = Sheet1.Cells(intReadRow, 1).End(xlToRight).Column() + 1

        Else

            'We are on a row that needs to be concatenated and deleted
            'So loop through all of the columns to get their values
            'And write their values to the read row and read col
            Do Until Sheet1.Cells(intReadRow, intReadCol).Value = ""
                Sheet1.Cells(intWriteRow, intWriteCol).Value = Sheet1.Cells(intReadRow, intReadCol).Value

                'increment read and write columns
                intWriteCol = intWriteCol + 1
                intReadCol = intReadCol + 1
            Loop

            'remove this rows values
            Sheet1.Rows(intReadRow).ClearContents

        End If
    Next intReadRow
End Sub