VBA Excel about transposing and custom sorting data

Question

I've inserted the code for reference. Let me preface by saying that I am not a programmer or anywhere close.

I have two columns of data in Sheet2. It looks something like this... 2columndata

I've transposed the data so it now repeats itself horizontally.

I want it to look like this... correct

Hopefully I've described this correctly. Basically want duplicates of the first column deleted, and anything that matches with data sets abc should correspond in the column next to it.

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

First, I highly suggest reading [How to avoid using `.Select`](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros), as this can cause some issues. — BruceWayne, Jun 23 '16 at 16:42

score 0 · Answer 1 · answered Jun 23 '16 at 17:46

The below code should return the results you are looking for. Make sure you amend the code to make sure that the sheet names match up. The code takes data down Column A and stores unique values as the keys to a Dictionary object. As values, it joins any existing values with commas. Finally it pushes the data over the Sheet2. Note: I assumed you have no headers but it shouldn't be too difficult to make that adjustment.

Let me know if this works or if you need additional help.

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

score 0 · Answer 2 · answered Jun 23 '16 at 17:56

An approach similar to @user3561813, also with a Dictionary. Original data in Sheet1, ordered data in 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

When changing a single 'b' to 'd' or a 'c' to a 'd', your code does not output 'd''s number in the correct row. — Cody Ｇ, Jun 23 '16 at 18:30

Cody Ｇ · Answer 3 · 2016-06-23T18:19:32.227

Another option, also assuming headerless table, and using built-in excel functions and arrays instead of the dictionary object.

Note: to get the most out of this code you should disable screen updating, status bar, calculations, etc.

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

Ron Rosenfeld · Answer 4 · 2016-06-23T20:39:32.703

Here is a somewhat different approach. We create a User Defined Object (Class) which consists of each unique Column A item, and a collection of the associate Column B items.

We create a Collection of these class objects, using the property of the Collection object that two items cannot have the same key. If they do, it creates a trappable error, which we can then use to add the colB item to the ColB collection in that class.

An advantage is understandable properties, and easy maintainablility. Also, by doing all the work in VBA and using VBA arrays, speed is quite good, even with large databases.

I named the Class module cColaStuff, and you will have to rename it as such when you insert it. But you can name it anything.

Class Module

'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

Regular Module

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

VBA Excel about transposing and custom sorting data

4 Answers4

Class Module

Regular Module