关于转置和自定义排序数据的VBA Excel

Question

我已插入代码以供参考。让我先说一下，我不是程序员或任何接近的程序员。

我在Sheet2中有两列数据。它看起来像这样...... 2columndata

我已经转置了数据，因此它现在可以水平重复。

我希望它看起来像这样...... correct

希望我已经正确地描述了这一点。基本上要删除第一列的重复项，并且与数据集abc匹配的任何内容都应该在它旁边的列中对应。

Sub Macro1()
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    Lastrow = Range("A65536").End(xlUp).Row

    For i = 1 To Lastrow
        Sheets("Sheet1").Select

        If Cells(i, 1) = "Vendor" Or Cells(i, 1) = "Computer Name" Or Cells(i, 1) = "Version" Or Cells(i, 1) = "Name" _
        Then
            Rows(i & ":" & i).Select
            Selection.Copy
            Sheets("Sheet2").Select
            PasteRow = Range("F65536").End(xlUp).Offset(1, 0).Row
            Rows(PasteRow & ":" & PasteRow).Select
            Selection.Insert Shift:=xlDown

    Worksheets("Sheet2").Range("A1:A500").Copy
    Worksheets("Sheet3").Range("A1").PasteSpecial Transpose:=True

    Worksheets("Sheet2").Range("B1:B500").Copy
    Worksheets("Sheet3").Range("A2").PasteSpecial Transpose:=True


        End If

    Next i

        Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Answer 1

以下代码应返回您要查找的结果。确保修改代码以确保工作表名称匹配。代码将数据下移到列A并将唯一值存储为Dictionary对象的键。作为值，它使用逗号连接任何现有值。最后，它将数据推送到Sheet2。注意：我认为你没有标题，但进行调整不应该太难。

如果有效，或者您需要其他帮助，请告诉我。

Sub SummarizeInNewSheet()
    Dim sCurrent As Worksheet
    Dim sNew As Worksheet
    Dim rCurrent As Range
    Dim oDict As Object
    Dim rIterator As Range
    Dim nNewLastCol As Long
    Dim vTemp As Variant

    Set sCurrent = Worksheets("Sheet1")
    Set sNew = Worksheets("Sheet2")
    Set rCurrent = sCurrent.Range("A1:A" & sCurrent.Cells(Rows.Count, 1).End(xlUp).Row)

    Set oDict = CreateObject("Scripting.Dictionary")

    For Each rIterator In rCurrent
        If Not oDict.exists(rIterator.Value) Then
            oDict(rIterator.Value) = rIterator.Offset(, 1).Value
        Else
            oDict(rIterator.Value) = JoinValues(oDict(rIterator.Value), rIterator.Offset(, 1).Value, ",")
        End If
    Next rIterator

    nNewLastCol = 1
    With sNew
        For Each k In oDict.keys
            .Cells(1, nNewLastCol).Value = k
            vTemp = Split(oDict(k), ",")
            .Cells(2, nNewLastCol).Resize(UBound(vTemp) + 1, 1).Value = Application.Transpose(vTemp)
            nNewLastCol = nNewLastCol + 1
        Next k
    End With
End Sub


Private Function JoinValues(sOld As String, sNew As String, sDelim As String) As String
    If Len(sOld) = 0 Then
        JoinValues = sNew
    Else
        JoinValues = sOld & sDelim & sNew
    End If
End Function

Answer 2

类似于@ user3561813的方法，也是一个字典。 <StackPanel xmlns:he="clr-namespace:HollowEarth" Orientation="Vertical" HorizontalAlignment="Left" > <Slider Minimum="0" Maximum="10" x:Name="SignalSlider" Width="200" SmallChange="1" LargeChange="4" TickFrequency="1" IsSnapToTickEnabled="True" /> <he:SignalBars HorizontalAlignment="Left" Value="{Binding Value, ElementName=SignalSlider}" InactiveBarFillBrush="White" Foreground="DarkRed" /> </StackPanel> 中的原始数据，Sheet1中的有序数据。

Sheet2

Answer 3

另一个选项，也是假定无头表，并使用内置的excel函数和数组而不是字典对象。

注意：要充分利用此代码，您应禁用屏幕更新，状态栏，计算等。

Sub Test()

    Dim ws As Worksheet
    Dim myRange As Range
    Dim myColumnHeaders As Range
    Dim myData As Variant
    Dim myHeaders As Variant
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set myRange = ws.Range(ws.Cells(1, 1), ws.Cells(Rows.Count, 2).End(xlUp))
    myData = ws.Range(ws.Cells(1, 1), ws.Cells(Rows.Count, 2).End(xlUp)).Value

    ' Get the Column Headers
    Call myRange.RemoveDuplicates(Array(1)) ' Use Column 1 as from which to remove duplicates.
    ' Set the column headers to an array.
    myHeaders = ws.Range(ws.Cells(1, 1), ws.Cells(Rows.Count, 1).End(xlUp)).Value

    ' Clear the sheet.
    Call ws.Cells.Clear

    ' Now we've got the data, so sort and place away.
    For nRowHeader = 1 To UBound(myHeaders, 1)
      ws.Cells(1, nRowHeader) = myHeaders(nRowHeader, 1) ' Rows of the Headers become columns of the table.
      nDataRow = 2 ' The starting row.
      For nRowData = 1 To UBound(myData, 1) ' For each row of the data...
        ' See if it matches the column.
        If myData(nRowData, 1) = myHeaders(nRowHeader, 1) Then
            ' Add the data to the column's row and move to the next spot.
            ws.Cells(nDataRow, nRowHeader) = myData(nRowData, 2) ' Could optimize further here using an array per column instead. (Write operations to cells are expensive)
            nDataRow = nDataRow + 1
        End If
      Next nRowData
    Next


End Sub

Answer 4

这是一种有些不同的方法。我们创建一个用户定义的对象（类），它由每个唯一的A列项和一组关联的B列项组成。

我们使用Collection对象的属性创建这些类对象的Collection，这两个item不能具有相同的键。如果他们这样做，它会创建一个可捕获的错误，然后我们可以使用它将colB项添加到该类中的ColB集合。

优点是易于理解的特性，易于维护。此外，通过在VBA中完成所有工作并使用VBA阵列，速度非常好，即使对于大型数据库也是如此。

我将类模块命名为cColaStuff，您必须在插入时将其重命名。但你可以说出任何名称。

班级单元

'RENAME this module **cCOLaStuff**

Option Explicit
Private pColA As String
Private pColB As String
Private pColBs As Collection

Public Property Get ColA() As String
    ColA = pColA
End Property
Public Property Let ColA(Value As String)
    pColA = Value
End Property

Public Property Get ColB() As String
    ColB = pColB
End Property
Public Property Let ColB(Value As String)
    pColB = Value
End Property

Public Property Get ColBs() As Collection
    Set ColBs = pColBs
End Property
Public Function ADDColB(Value As String)
    pColBs.Add Value
End Function

Private Sub Class_Initialize()
    Set pColBs = New Collection
End Sub

常规模块

Option Explicit
Sub CombineAB()
    Dim cC As cCOLaStuff, colC As Collection
    Dim wsSrc As Worksheet, wsResults As Worksheet, rResults As Range
    Dim vSrc As Variant, vResults As Variant
    Dim I As Long, J As Long

'Change sheets as needed
Set wsSrc = Worksheets("sheet1")
Set wsResults = Worksheets("sheet2")
    Set rResults = wsResults.Cells(1, 1)

'Get the source data
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With

'Collect the data, ColA as the key, and a collection of ColB stuff
Set colC = New Collection
On Error Resume Next 'to detect the duplicates
For I = 2 To UBound(vSrc, 1) 'skip the header row
    Set cC = New cCOLaStuff
    With cC
        .ColA = vSrc(I, 1)
        .ColB = vSrc(I, 2)
        .ADDColB .ColB

        colC.Add Item:=cC, Key:=CStr(.ColA)

        Select Case Err.Number
            Case 457  'we have a duplicate, so add ColB to previous object
                Err.Clear
                colC(CStr(.ColA)).ADDColB .ColB
            Case Is <> 0 'debug stop
                Debug.Print Err.Number, Err.Description
                Stop
        End Select
    End With
Next I
On Error GoTo 0

'create the results array
'row count = ColBs with the highest count (+1 for the header row)
J = 0
For I = 1 To colC.Count
    J = IIf(J >= colC(I).ColBs.Count, J, colC(I).ColBs.Count)
Next I

'Column count = number of collection items
ReDim vResults(0 To J, 1 To colC.Count)

'Populate the array
For J = 1 To UBound(vResults, 2)
    I = 0
    With colC(J)
        vResults(I, J) = .ColA
        For I = 1 To .ColBs.Count
            vResults(I, J) = .ColBs(I)
        Next I
    End With
Next J

'write the results to the worksheet
Set rResults = rResults.Resize(UBound(vResults, 1) + 1, UBound(vResults, 2))
With rResults
    .EntireColumn.Clear
    .Value = vResults
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
End With
End Sub