Question

所以目前，根据标题，我正在寻找一个智能且相对自动的转置系统。

到目前为止，我唯一知道如何做到这一点的方法是使用宏，粘贴特殊和大量手工工作（处理2,000~行表）。

以下示例是一个示例。所有事件都属于A1，但在新行中向下分布。目标是将它们全部放在一行中（在单个单元格中或相邻单元格中）。

git config core.autocrlf  false

所有事件都属于A1，但在新行中向下分布。目标是将它们全部放在一行中（在单个单元格中或相邻单元格中）。我需要它们的例子如下所示。

A       Event 1
A       Event 2
A       Event 3
B       Group 1
B       Group 2

我已经远距离搜索，但没有找到解决这个奇怪请求的任何东西。

Answer 1

您可以使用字典轻松完成此操作。看看下面的内容。您需要使用输入和目标范围更新两个With块

Public Sub test()
    Dim dict As Object
    Dim arr As Variant, tmp As Variant
    Dim i As Long
    Dim key

    Set dict = CreateObject("Scripting.Dictionary")

    ' Source Data
    With Sheet1
        arr = .Range(.Cells(1, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "B")).Value2
    End With

    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not IsEmpty(tmp) Then Erase tmp
        If dict.exists(arr(i, 1)) Then
            tmp = dict(arr(i, 1))
            ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
            tmp(UBound(tmp)) = arr(i, 2)
            dict(arr(i, 1)) = tmp
        Else
            ReDim tmp(0)
            tmp(LBound(tmp)) = arr(i, 2)
            dict.Add key:=arr(i, 1), Item:=tmp
        End If
    Next i

    ' Destination
    With Sheet1.Cells(1, 5)
        i = 0
        For Each key In dict.keys
            .Offset(i, 0) = key
            '' Side by side
            Range(.Offset(i, 1), .Offset(i, UBound(dict(key)) + 1)).Value2 = dict(key)
            '' In one cell
            '.Offset(i, 1).Value2 = Join(dict(key), ",")
            i = i + 1
        Next key
    End With
End Sub

Answer 2

假设我们的数据列在 A 和 B 列中，如：

运行此代码：

Sub Macro1()
    Dim Na As Long, Nd As Long, rc As Long
    Dim i As Long, j As Long, K As Long
    Dim v As Variant

    Range("A:A").Copy Range("D:D")
    Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo

    rc = Rows.Count
    K = 5
    Na = Cells(rc, "A").End(xlUp).Row
    Nd = Cells(rc, "D").End(xlUp).Row
    For i = 1 To Nd
        v = Cells(i, "D")
        For j = 1 To Na
            If v = Cells(j, 1) Then
                Cells(i, K) = Cells(j, 2)
                K = K + 1
            End If
        Next j
        K = 5
    Next i
End Sub

将产生：

智能转置的宏

2 个答案: