VBA Excel关于转置和自定义sorting数据
我已插入代码以供参考。 让我说，我不是一个程序员或任何接近。
我在Sheet2中有两列数据。 它看起来像这样… 2columndata
我已经调换了数据，所以现在水平重复。
我希望它看起来像这样… 正确
希望我已经正确描述了这一点。 基本上希望删除第一列的重复项，并且任何与数据集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 下面的代码应该返回你正在寻找的结果。 确保您修改了代码，以确保表格名称匹配。 该代码将数据向下取出列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
一种类似于@ user3561813的方法，也有一个Dictionary。 Sheet1原始数据， Sheet2有序数据。
Private Sub Test() Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU1 As Long Dim k As Integer, i As Integer, j As Integer, m As Integer 'Create a Dictionary with unique values of column A Set dU1 = CreateObject("Scripting.Dictionary") lrU1 = Cells(Rows.Count, 1).End(xlUp).Row cU1 = Range("A1:A" & lrU1) If lrU1 > 1 Then For iU1 = 1 To UBound(cU1, 1) dU1(cU1(iU1, 1)) = 1 Next iU1 End If 'Now dU1 has unique values from column A 'if you want to see what is in Dictionary, uncomment next three lines 'For i = 0 To dU1.Count - 1 ' MsgBox "dU1 has " & dU1.Count & " elements and key#" & i & " is " & dU1.Keys()(i) 'Next 'Write columns headers For i = 0 To dU1.Count - 1 Worksheets("Sheet2").Cells(1, i + 1) = dU1.Keys()(i) Next j = 0 m = 2 For k = 1 To UBound(cU1, 1) 'For each row of data For i = 0 To dU1.Count - 1 If Worksheets("Sheet1").Cells(k, 1).Value = dU1.Keys()(i) Then Worksheets("Sheet2").Cells(m, i + 1) = Worksheets("Sheet1").Cells(k, 2) j = j + 1 End If If j = dU1.Count Then 'go to next Sheet2 row after completing all three values (a,b,c) m = m + 1 j = 0 End If Next Next End Sub
另外一个选项，也是假设无标题表，并且使用内置的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
这是一个有点不同的方法。 我们创build一个用户定义对象（Class），它由每个唯一的Column A项目和一个关联的Column B项目组成。
我们使用Collection对象的属性创build这些类对象的集合，这两个对象不能具有相同的键。 如果他们这样做，它会创build一个可捕获的错误，然后我们可以使用colB项目添加到该类的ColB集合。
优点是可以理解的特性，并且易于维护。 而且，通过在VBA中使用所有工作并使用VBAarrays，即使在大型数据库的情况下，速度也是相当不错的。
我将Class模块命名为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