Excel 复制、转置和删除重复信息VBA

我正试图根据另一列的单元格信息转换数据

当我只有两个相同的数据时，我可以相当快地使用下面的宏。我的问题是当我点击多个相同的数据时

例如：

Clients   What they want
    20    B
    20    C
    33    B
    33    C
    202   A
    202   B
    202   C
    55    A
    55    C

我的宏是这样的

Sub TransposeDuplciateData()
    Sheets("Duplicate").Select
    While Range("A2") <> ""
        Range("B2").Select
        ActiveCell.Resize(2, 1).Select
        Selection.Copy
        Sheets("Clients").Select
        Range("B1").Select
        Selection.End(xlDown).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
        Sheets("Duplicate").Select
        Selection.EntireRow.Delete Shift:=xlUp
    Wend
End Sub     

---

实现预期结果的一种可能方法是使用透视表。 如果将列A设置为行，将列B设置为列，将值设置为列B的计数，则会得到以下输出

     A   B   C  
20       1   1 
33       1   1 
55   1       1
202  1   1   1

那会有帮助吗

对于基于宏的解决方案，请尝试以下代码。它可能需要根据您的确切需要进行调整。还要确保列A以某种方式排序（这也可以在宏中完成）

Sub-remove_dub（）
附页（“双硅酸盐”）
Dim row_dubl为整数
作为整数的Dim row\u clie
作为整数的Dim col_clie
行dubl=1
行clie=1
col_clie=2
While.Cells（A行）
表格（“客户”）.单元格（A行）=.单元格（A行）
表格（“客户”）。单元格（第列、第列）=单元格（第列、第列）
如果.Cells（row_dubl，“A”）=.Cells（row_dubl+1，“A”），则
行clie=行clie
col_clie=col_clie+1
其他的
行clie=行clie+1
col_clie=2
如果结束
row_dubl=row_dubl+1
温德
以
端接头

---

这里有一个宏，它创建了一个用户定义的对象作为一个类，该类具有客户端属性和一个opt字典（用于Option）。如果要扩展此属性，可以轻松添加其他属性

设置对Microsoft脚本运行时的引用

编辑：重命名类模块

cClient

类模块 正则模 结果

有点“简化”的版本：

Dim c As Range
Set c = [a2]
While c > ""
    While c = c(2)                          ' while c equals the cell below it
        c.End(xlToRight)(, 2) = c(2, 2)     ' get the second value below c
        c(2).Resize(, 2).Delete xlShiftUp   ' delete the 2 cells below c
    Wend
    Set c = c(2)
Wend

---

我不能完全肯定我是否理解你的要求。你能发布一个屏幕截图，显示你发布的数据的输出是什么样子的吗？它似乎没有在表中显示出来，但基本上我在很多行上都有我的clents信息。A列是我的客户号，B列是他们想要的。我在A1 20和B1是B，然后A2又是20，B2是C。然后当我点击客户机号码202时，他的信息放在三个不同的行中。现在我想要的是在Sheet client列A中有一个客户机编号，并且在随后的列中有它们的所有选项。所以A2是20，B2是B，C2是C。当我点击客户端202时，它是A4是202，B4是C4是B，D4是C。希望这有助于澄清：-）你需要的是像下面提到的Axel一样的透视：）我宁愿使用宏而不是透视表，因为我不想一直更新透视表。我有一个宏来更新另一个工作表中的其他数据透视表，但是这个宏在每次下载时都会从零开始，所以只需点击一个按钮就会更容易：-）我添加了一个宏，它应该可以解决您的问题。确保A列已排序。如果需要，您可以删除宏末尾的sheet

Dublicate

中的整个表。我也将尝试此表，看看哪一个更易于操作（如果需要）。非常感谢谢谢，我将尝试：-）@ValS忘记注意必须重命名类模块

cClient

Sub remove_dub()

    With Sheets("Dublicate")
        Dim row_dubl As Integer
        Dim row_clie As Integer
        Dim col_clie As Integer

        row_dubl = 1
        row_clie = 1
        col_clie = 2

        While .Cells(row_dubl, "A") <> ""
            Sheets("Clients").Cells(row_clie, "A") = .Cells(row_dubl, "A")
            Sheets("Clients").Cells(row_clie, col_clie) = .Cells(row_dubl, "B")

            If .Cells(row_dubl, "A") = .Cells(row_dubl + 1, "A") Then
                row_clie = row_clie
                col_clie = col_clie + 1
            Else
                row_clie = row_clie + 1
                col_clie = 2
            End If

            row_dubl = row_dubl + 1
        Wend

    End With
End Sub

Option Explicit
Private pClient As String
Private pOpt As String
Private pOpts As Dictionary

Public Property Get Client() As String
    Client = pClient
End Property
Public Property Let Client(Value As String)
    pClient = Value
End Property

Public Property Get Opt() As String
    Opt = pOpt
End Property
Public Property Let Opt(Value As String)
    pOpt = Value
End Property

Public Property Get Opts() As Dictionary
    Set Opts = pOpts
End Property
Public Function ADDOpt(Value As String)
    If Not pOpts.Exists(Value) Then
        pOpts.Add Key:=Value, Item:=Value
    End If
End Function

Private Sub Class_Initialize()
    Set pOpts = New Dictionary
    pOpts.CompareMode = TextCompare
End Sub

Option Explicit
'Set reference to Microsoft Scripting Runtime
Sub OrganizeClientOptions()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cC As cClient, dC As Dictionary
    Dim I As Long, J As Long
    Dim V As Variant, W As Variant

'Set worksheets
Set wsSrc = Worksheets("sheet1")

On Error Resume Next
    Set wsRes = Worksheets("Results")
    If Err.Number = 9 Then
        Worksheets.Add.Name = "Results"
    End If
On Error GoTo 0
Set wsRes = Worksheets("Results")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With

'collect the data
Set dC = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cC = New cClient
    With cC
        .Client = vSrc(I, 1)
        .Opt = vSrc(I, 2)
        .ADDOpt .Opt
        If Not dC.Exists(.Client) Then
            dC.Add Key:=.Client, Item:=cC
        Else
            dC(.Client).ADDOpt .Opt
        End If
    End With
Next I

'Size vRes
J = 0
For Each V In dC.Keys
    I = dC(V).Opts.Count
    J = IIf(J > I, J, I)
Next V

ReDim vRes(0 To dC.Count + 1, 1 To J + 1)

'headers
vRes(0, 1) = "Client"
For J = 2 To UBound(vRes, 2)
    vRes(0, J) = "Option " & J - 1
Next J

'Data
I = 0
For Each V In dC.Keys
    I = I + 1
    vRes(I, 1) = V

    J = 1
    For Each W In dC(V).Opts
        J = J + 1
        vRes(I, J) = W
    Next W
Next V

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

Dim c As Range
Set c = [a2]
While c > ""
    While c = c(2)                          ' while c equals the cell below it
        c.End(xlToRight)(, 2) = c(2, 2)     ' get the second value below c
        c(2).Resize(, 2).Delete xlShiftUp   ' delete the 2 cells below c
    Wend
    Set c = c(2)
Wend