Excel macro to paste transpose based on repeated values in another column - excel

Question

The first set of data is a snippet of may data (running into thousands of rows) in the first two columns.
The first column has repeated ticket numbers with different status. I want to have a unique row for each ticket and corresponding columns to have the various status(a transpose like). See below illustration:
Incident Number Measurement Status
INCIN0001910583 Detached
INCIN0001910583 Missed
INCIN0001908104 Detached
INCIN0001908104 Detached
INCIN0001908104 Missed
INCIN0001914487 Met
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Met
INCIN0001910624 Met
INCIN0001910575 Detached
INCIN0001910575 Met
I'm looking for a macro (or formula) to achieve something like this:
INCIN0001910583 Detached Missed
INCIN0001908104 Detached Detached Missed
INCIN0001914487 Met
INCIN0001908444 Detached Detached Detached Met
INCIN0001910624 Met
INCIN0001910575 Detached Met
As Tom pointed out, below is the recorded macro I have been using to achieve this, pasting the transpose in the first occurrence of the unique Incident Number(column A) and then manually removing the blanks.(however it takes ages to complete it for thousands of rows)
Sub transpose_paste()
'
' transpose_paste Macro
'
' Keyboard Shortcut: Ctrl+t
'
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
Cells(ActiveCell.Row, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
End Sub

Answer 1

I'm not sure I understand why Tom gave you the advice he did. This wouldn't be a very good idea to get a recorded macro from because of the non-dynamic nature of recorded code as opposed to the dynamic nature of your data.
Here are two options. The first being what you asked for (run the 'PivotData_All' routine), the other being if you want to exclude non-unique items from the subsequent columns of data (run the 'PivotData_UniquesOnly' routine).
Sub PivotData_All()
With Worksheets("Sheet1")
Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), False)
End With
End Sub
Sub PivotData_UniquesOnly()
With Worksheets("Sheet1")
Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), True)
End With
End Sub
Sub PivotData( _
ByVal IncidentData As Range, _
Optional ByVal UniquesOnly As Boolean = False _
)
'
' Take data from a given range and pivot out data based on first column being incident numbers, second column being
' measurement status. Each unique incident will be given its own row and the measurment status will be pivoted out
' along columns on a new sheet.
'
' Syntax: PivotData(UniquesOnly)
'
' Parameters: IncidentData. Range. Required. A two-column set of data. Left column is incident number, right column
' is measurement status.
' UniquesOnly. Boolean. Optional. Specify whether second column of data should contain only unique values
' or not. If omitted False is passed.
'
Dim Incidents As Collection
Dim NewSheet As Worksheet
Dim Incident() As Variant
Dim IncidentItem As Variant
Dim IncidentTempValues() As Variant
Dim IncidentStep As Long
Dim IncidentMatch As Long
Dim IncidentKey As String
'// Change these as necessary
'// Get values into an array to start
IncidentTempValues = IncidentData.Value
'// Iterate through array to get unique values, append all measurements to individual array
Set Incidents = New Collection
For IncidentStep = LBound(IncidentTempValues, 1) To UBound(IncidentTempValues, 1)
IncidentKey = CStr(IncidentTempValues(IncidentStep, 1))
If InCollection(Incidents, IncidentKey) = False Then
Incident = Array(IncidentKey, IncidentTempValues(IncidentStep, 2))
Incidents.Add Incident, IncidentKey
Else
Erase Incident
Incident = Incidents.Item(IncidentKey)
IncidentMatch = 0
If UniquesOnly Then
On Error Resume Next
IncidentMatch = WorksheetFunction.Match(IncidentTempValues(IncidentStep, 2), Incident, 0)
On Error GoTo 0
End If
If IncidentMatch = 0 Then
ReDim Preserve Incident(LBound(Incident) To UBound(Incident) + 1)
Incident(UBound(Incident)) = IncidentTempValues(IncidentStep, 2)
Incidents.Remove IncidentKey
Incidents.Add Incident, IncidentKey
End If
End If
Next IncidentStep
'// Put values into new sheet
If Incidents.Count > 0 Then
Set NewSheet = Worksheets.Add
IncidentStep = 1
For Each IncidentItem In Incidents
NewSheet.Cells(IncidentStep, 1).Resize(1, UBound(IncidentItem) - LBound(IncidentItem) + 1).Value = IncidentItem
IncidentStep = IncidentStep + 1
Next IncidentItem
NewSheet.Cells.EntireColumn.AutoFit
End If
'// Message user upon completion
If Incidents.Count > 0 Then
MsgBox "New sheet created ('" & NewSheet.Name & "') with " & Incidents.Count & " record(s).", vbInformation, "Complete"
Else
MsgBox "Unable to create incident data.", vbExclamation, "Whoops!"
End If
End Sub
Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax: InCollection(CheckCollection,CheckKey)
'
' Parameters: CheckCollection. Collection. Required. The collection to search in.
' CheckKey. String. Required. The string key to search in collection for.
'
On Error Resume Next
InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
On Error GoTo 0
End Function
This would need to go into a standard module. Let us know if you need additional assistance with this.
Regards,
Zack Barresse

Answer 2

This procedure assumes the following:
Data ranges starts at A1, includes two columns and it's a continuous range of data (i.e. no blank rows in between, and column C is blank
Output data starts at D1
Sub Rng_List_Unique_Records()
Dim vSrc As Variant, sKey As String
Dim sStatus As String, aStatus As Variant
Dim lRow As Long, l As Long
With ThisWorkbook.Sheets(1)
Application.Goto .Cells(1), 1
Rem Set Array with Source Range Data
vSrc = .Cells(1).CurrentRegion.Value2
Rem Extract Unique Items
For l = 1 To UBound(vSrc)
If vSrc(l, 1) = sKey Then
Rem Same Incident - Add Measurement
sStatus = sStatus & ";" & vSrc(l, 2)
Else
If sStatus <> Empty Then
Rem Enter Measurements for Prior Incident
aStatus = Split(sStatus, ";")
.Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus
End If
Rem New Incident
lRow = 1 + lRow
sKey = vSrc(l, 1)
.Cells(lRow, 4) = sKey
sStatus = vSrc(l, 2)
End If: Next
Rem Enter Measurements for Last Incident
aStatus = Split(sStatus, ";")
.Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus
Rem Output Range Columns AutoFit
.Cells(4).CurrentRegion.EntireColumn.AutoFit
End With
End Sub
Suggest to visit the following pages to obtain a deeper understanding of the resources used:
Variables & Constants, Application Object (Excel), Excel Objects
With Statement, For Each...Next Statement, If...Then...Else Statement
Range Object (Excel), Worksheet Object (Excel)
Nevertheless let me know of any questions about the procedure

Answer 3

It's been a slow day so..... This will do what you want using vba. You could also achieve this as Scott has said above with formulas or even using a pivot table. However by the looks of the question you're looking for something dynamic which will expand automatically to include new incidents which the formulas won't do easily.
I've over commented it in the hopes that you will easily be able to understand for future modifications. This is probably not the only way of doing it and not necessarily the best.
Option Explicit
Sub transposeAndCombine()
' Declare all of the variable names and types we will be using
Dim inc As Object
Dim c As Integer: Dim i As Integer
Dim rng As Range
Dim f
Dim ws as worksheet
' Turns off screen updating - good practice for the majority of vba macros
Application.ScreenUpdating = False
' Declare worksheet
set ws = ThisWorkbook.Sheets("Sheet1")
' Change Sheet1 to relevant sheet
' You'll also need to change all 4's that are detailed below to your relevant destination.
' I put all the processed data into Column D in my example
' starting from row 2 to leave a row for a header
With ws
' Declare range that we are going to be considering (where the raw data is)
Set rng = Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
' Loop through that data
For Each inc In rng
' Find if data exists in destination
Set f = .Columns(4).Find(inc.Value, LookIn:=xlValues)
' If it exists assign the row number to a variable, if not add it to the end
If Not f Is Nothing Then
i = f.Row
Else
i = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
.Cells(i, 4) = inc.Value
End If
' find last column that has been used
c = .Cells(i, .Columns.Count).End(xlToLeft).Column + 1
' add the Status value to the row
.Cells(i, c) = inc.Offset(0, 1)
' Loop back for next data entry
Next inc
End With
' Turn back on screen updating for normal behaviour
Application.ScreenUpdating = True
End Sub