Question

我正在尝试根据另一列的单元格信息转置数据。

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

例如：

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

问题是当我点击202号客户端时，他想要三件不同的东西，不仅仅是两件。

因此，我正在寻找一个宏，它首先会识别客户端显示的次数，然后从列B复制相关信息并将其转置到我的Clients工作表中，然后删除我的Duplicate表单中的整行（自从我处理完毕后）并转移到下一个客户端信息并执行相同操作，直到没有更多客户端信息为止。

这是最终结果，我希望它看起来像

Clients Option 1    Option 2    Option 3    Option 4    
20      B            C              
33      B            C              
202     A            B            C         
55      B            C

Answer 1

实现所需结果的可能方法是使用数据透视表。如果将A列设置为Row，将B列设置为Column，将值设置为B列的计数，则会得到以下输出。

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

那会有帮助吗？

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

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

祝你好运

Answer 2

这是一个宏，它将用户定义的对象创建为一个类，它具有Client的属性和Opts的字典（对于Option）。如果要扩展此属性，可以轻松添加其他属性。

设置对Microsoft Scripting Runtime的引用

编辑：重命名班级模块cClient

班级单元

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

结果

Answer 3

有点＆＃34;简化＆＃34;版本：

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

复制，转置和删除重复信息VBA

3 个答案:

班级单元

常规模块

结果