Question

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

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

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

我希望将A的值组合成一行，如目标图片所示。

Excel工作表预先排序，因此ColumnA中的所有重复项始终显示在一起。

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

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

为了使任务更容易，转换后无需删除空白行。

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

到目前为止这项任务。

其实我之前问过类似的问题：Excel VBA: How to transform this kind of cells?

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

所以请帮帮我〜

但请不要忘记周末愉快〜

谢谢！

Answer 1

尝试下面的代码（＆＃34;奖励＆＃34;功能，也删除空行）。正如您在帖子中所写的那样，数据按照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

Excel VBA：如何查找重复项并进行转置？

2 个答案: