## How to sort a list of data based on three columns in the right order? - excel

Below you see a piece of code which is used to:
First sort a list of data, based on first the Entity column, second on the GREN column and third on the IC column. And then compiling the data which has the same Entity, GREN and IC column.
For some reason, I get the following error when I run the code:
Run-time error '1004': Method 'Range' of object '_Global' failed.
It is not failing when sorting the other columns and when I use less data it seems to work perfectly fine. Does anyone understand what goes wrong? And more importantly how to fix it?
Sub itest()
Dim EntityCol As Long, GRENCol As Long, ICCol As Long, ValueCol As Long, i As Long
Dim firstrow As Long, lastrow As Long, rngData As Range
Worksheets("FC_OUTPUT").Activate
Application.ScreenUpdating = False
EntityCol = 4 ' column D
GRENCol = 8
ICCol = 9
ValueCol = 12 ' column L
firstrow = 7
lastrow = Cells(Rows.Count, EntityCol).End(xlUp).Row
With ActiveSheet.Sort
.SortFields.Add Key:=Range(Cells(firstrow, EntityCol)), Order:=xlAscending
.SortFields.Add Key:=Range(Cells(firstrow, GRENCol)), Order:=xlAscending
.SortFields.Add Key:=Range(Cells(firstrow, ICCol)), Order:=xlAscending
.SetRange Range(Cells(firstrow, 1), Cells(lastrow, 96))
.Header = xlNo
.Apply
End With
Set rngData = Range(Cells(firstrow, 1), Cells(lastrow, 96)) ' this line should be adjusted but you'll need to also adjust firstrow and lastrow
With rngData
' Here I'll start a loop for every row going from the end to the beginning, to prevent issues when removing rows
For i = lastrow To firstrow Step -1
' Here I'll use the If statement to check if the values are the same as the previous row
If .Cells(i, EntityCol) = .Cells(i - 1, EntityCol) And _
.Cells(i, GRENCol) = .Cells(i - 1, GRENCol) And _
.Cells(i, ICCol) = .Cells(i - 1, ICCol) Then
' This is where you'll do your addition and delete
.Cells(i - 1, ValueCol).Value2 = .Cells(i - 1, ValueCol) + .Cells(i, ValueCol)
.Rows(i).Delete
End If
Next i
End With
End Sub

Here's how I'd do it:
Sub tgr()
Const lEntityCol As Long = 4 'Column D
Const lGRENCol As Long = 8 'Column H
Const lICCol As Long = 9 'Column I
Const lValueCol As Long = 12 'Column L
Const lDataStartRow As Long = 7 'Actual data (not headers) starts on row 7
Dim ws As Worksheet
Dim rData As Range
Dim rDel As Range
Dim hUnq As Object
Dim aData As Variant
Dim sTemp As String
Dim sDelim As String
Dim i As Long
Set ws = ActiveWorkbook.Worksheets("FC_OUTPUT")
Set rData = ws.Range("A" & lDataStartRow & ":CR" & ws.Cells(ws.Rows.Count, lEntityCol).End(xlUp).Row)
Set hUnq = CreateObject("Scripting.Dictionary")
sDelim = "|" 'This is a character that will not be in your data
With rData
If .Row < lDataStartRow Then Exit Sub 'No data
.Sort Key1:=Intersect(.Cells, ws.Columns(lEntityCol)), Order1:=xlAscending, _
Key2:=Intersect(.Cells, ws.Columns(lGRENCol)), Order2:=xlAscending, _
Key3:=Intersect(.Cells, ws.Columns(lICCol)), Order3:=xlAscending, _
Header:=xlNo
aData = .Value
End With
For i = LBound(aData, 1) To UBound(aData, 1)
If Len(Trim(aData(i, lEntityCol))) > 0 _
And Len(Trim(aData(i, lGRENCol))) > 0 _
And Len(Trim(aData(i, lICCol))) > 0 Then
sTemp = LCase(Trim(aData(i, lEntityCol))) & sDelim & LCase(Trim(aData(i, lGRENCol))) & sDelim & LCase(Trim(aData(i, lICCol)))
If Not hUnq.exists(sTemp) Then
'New unique combination of Entity, GREN, and IC found
hUnq.Add sTemp, sTemp
'Get the total sum of values for the unique combination
rData.Cells(i, lValueCol).Value = WorksheetFunction.SumIfs(ws.Columns(lValueCol), _
ws.Columns(lEntityCol), aData(i, lEntityCol), _
ws.Columns(lGRENCol), aData(i, lGRENCol), _
ws.Columns(lICCol), aData(i, lICCol))
Else
'Not a new unique combination, add it to the list of rows to be deleted
If rDel Is Nothing Then Set rDel = rData.Cells(i, 1) Else Set rDel = Union(rDel, rData.Cells(i, 1))
End If
End If
Next i
If Not rDel Is Nothing Then rDel.EntireRow.Delete
End Sub

## Related

### Copy from a range and past in another sheet in the next empty cell in a row

I would like to have some tips to start a VBA code: I have 2 sheets. Each row of the sheet(2) has text in each cells but between them it can have some empty cell. My goal is to copy start from the row1 of sheet(2) from A1 to E1 and past it in the sheet(1) row 1 but without empty cell between them. I edit my post because i did not thought about this important details. I would like to erase any duplicate in the same row but to keep the first entry. And repeat the operation until the last row. Data exemple: Worksheet(2): row1 cell1, cell2, cell3,cell4,cell5: **ABC**, ,DEF,**ABC**,GHI row(2) cell1, cell2, cell3,cell4,cell5: ZZZ, , , ,YEU Resultat expected: Worksheet(1): row1 cell1, cell2, cell3,cell4,cell5: **ABC**,DEF,GHI, , , row(2) cell1, cell2, cell3,cell4,cell5: ZZZ,YEU, , , Thank you for your help in advance!

Try this: Sub stack_overflow() Dim lngLastRow As Long Dim xNum As Long Dim xCell As Range Dim shtFrom As Worksheet Dim shtTo As Worksheet Dim lngColCount As Long 'Change the two lines below this to change which sheets you're working with Set shtFrom = ActiveWorkbook.Sheets(2) Set shtTo = ActiveWorkbook.Sheets(1) lngLastRow = shtFrom.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row For xNum = 1 To lngLastRow lngColCount = 1 For Each xCell In shtFrom.Range("A" & xNum & ":E" & xNum) If xCell.Value <> "" Then If shtTo.Range("A" & xNum & ":E" & xNum).Find(What:=xCell.Value, LookIn:=xlValues, Lookat:=xlWhole) Is Nothing Then shtTo.Cells(xNum, lngColCount).Value = xCell.Value lngColCount = lngColCount + 1 End If End If Next xCell Next xNum End Sub

I found it: Sub M() lastrow = Sheets("Sheet2").Range("A1").SpecialCells(xlCellTypeLastCell).Row For i = 1 To lastrow Sheets("Sheet2").Range("A" & i & ": M" & i).Copy Sheets("Sheet1").Range("A" & i) ' Change Column M as required Sheets("Sheet1").Range("A" & i & ": M" & i).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft Next End Sub

You are going to have to provide some string manipulation after collecting the values from each row in order to remove the blanks. Sub contract_and_copy() Dim rw As Long, lr As Long, lc As Long, ws As Worksheet Dim sVALs As String, vVALs As Variant Set ws = Sheets("Sheet1") With Sheets("Sheet2") lr = .Cells.Find(what:=Chr(42), after:=.Cells(1, 1), SearchDirection:=xlPrevious).Row For rw = 1 To lr If CBool(Application.CountA(Rows(rw))) Then vVALs = .Cells(rw, 1).Resize(1, .Cells(rw, Columns.Count).End(xlToLeft).Column).Value sVALs = ChrW(8203) & Join(Application.Index(vVALs, 1, 0), ChrW(8203)) & ChrW(8203) Do While CBool(InStr(1, sVALs, ChrW(8203) & ChrW(8203))) sVALs = Replace(sVALs, ChrW(8203) & ChrW(8203), ChrW(8203)) Loop sVALs = Mid(sVALs, 2, Len(sVALs) - 2) vVALs = Split(sVALs, ChrW(8203)) ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(vVALs) + 1) = vVALs End If Next rw 'Debug.Print lr End With End Sub I've used a zero-length space as the delimiter as it is usually unlikely to be a part of a user's data.

You can try below approach also... Public Sub remove_blank() Dim arrayValue() As Variant ThisWorkbook.Sheets("Sheet1").Activate ' Sheet1 has the data with blanks arrayValue = range("A1:H2") ' Range where the data present... Dim i As Long Dim j As Long Dim x As Integer: x = 1 Dim y As Integer: y = 1 For i = 1 To UBound(arrayValue, 1) For j = 1 To UBound(arrayValue, 2) Dim sStr As String: sStr = arrayValue(i, j) If (Len(Trim(sStr)) <> 0) Then ThisWorkbook.Sheets("Sheet2").Cells(x, y).Value = sStr ' Sheet2 is the destination y = y + 1 End If Next j x = x + 1 y = 1 Next i End Sub

### How to get the sum of two adjacent columns into one merged cell (VBA)?

I am creating a summary macro and I need to add up all the values of column C and D into the merged cell in E. In the image attached the sums are already placed to show the result I want. I already have code to merge the cells in column E based on the names in A. IE Sum up all overdue and critical for bob and place in merged column, then nick. Here is what I have I just need help getting the sum: Sub MergeSameCell() Dim Rng As Range, xCell As Range Dim xRows As Integer Set WorkRng = ThisWorkbook.Worksheets("Summary").Range("A:A") lastRow = ActiveSheet.Columns("A").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row xRows = lastRow For Each Rng In WorkRng.Columns For i = 1 To xRows - 1 For j = i + 1 To xRows If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then Exit For End If Next WorkRng.Parent.Range(Rng.Cells(i, 5), Rng.Cells(j - 1, 5)).Merge i = j - 1 Next Next End Sub

The below uses your enclosed data specifically and assumes the data has already been sorted by column A and the cells in column E are already merged. Public Sub GroupSum() Dim i0 As Long, i1 As Long, strName As String With ActiveSheet For i0 = 2 To .UsedRange.Rows.Count If Not .Cells(i0, 1).Value = strName Then strName = .Cells(i0, 1) i1 = i0 End If .Cells(i1, 5).Value = .Cells(i0, 3).Value + .Cells(i0, 4).Value + .Cells(i1, 5).Value Next i0 End With End Sub

I will leave the alignment formatting of the merged cells to you. Option Explicit Sub MergeSameCell() Dim clientRng As Range Dim lastRow As Long, lastClientRow As Long With ThisWorkbook.Worksheets("Summary") .Columns(5).UnMerge Set clientRng = .Range("A2") lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row Do lastClientRow = .Columns(1).Find(what:=clientRng.Value, after:=clientRng, _ lookat:=xlWhole, SearchDirection:=xlPrevious).Row With clientRng.Offset(0, 4) .Resize(lastClientRow - clientRng.Row + 1, 1).Merge .Formula = "=sumifs(c:c, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")+" & _ "sumifs(d:d, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")" 'optionally revert the formulas to their returned value 'value = .value2 End With Set clientRng = clientRng.Offset(lastClientRow - clientRng.Row + 1, 0) Loop While clientRng.Row <= lastRow End With End Sub

This removes a couple of loops: Sub MergeSameCell() With ThisWorkbook.Worksheets("Summary") Dim i as Long For i = 2 To .Rows.Count If .Cells(i, 1) = "" Then Exit Sub Dim x As Long x = .Evaluate("MATCH(TRUE," & .Cells(i, 1).Address & "<>" & .Range(.Cells(i, 1), .Cells(.Rows.Count, 1)).Address & ",0) - 2 + " & i) .Cells(i, 5).Value = Application.Sum(.Range(.Cells(i, 3), .Cells(x, 4))) .Range(.Cells(i, 5), .Cells(x, 5)).Merge i = x Next i End With End Sub

### How to copy top and remaining values to different cell in Excel VBA

I would like to select the top 10 Values from Main table and paste in different range (E3) and REMAINING all values and PASTE and SUM in another range(I3) I used the code below. It is working for Top 10 values, BUT for remaining, when i am adding one more row in Main table, it is not working. Help me. Private Sub CommandButton1_Click() 'Calculation for Top 10 Countries Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Offset(-9, -2).Resize(10, 3).Copy Sheets("Sheet1").Range("E3") 'Calculation for Remaining Countries Range("A3:C14").Copy Range("I3") Range("I15").Select ActiveCell.FormulaR1C1 = "Remaining" Range("J15").Select ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" Range("K15").Select ActiveCell.FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" End Sub

Please try this code. Option Explicit Private Sub CommandButton1_Click() Dim Rng As Range Dim R As Long, Rl As Long ' last row With Worksheets("Sheet1") Rl = .Cells(.Rows.Count, "A").End(xlUp).Row R = Application.Max(Rl - 9, 3) ' pick Top 10 Countries Set Rng = Range(.Cells(R, "A"), .Cells(Rl, "C")) Rng.Copy Destination:=.Cells(3, "E") ' pick remaining countries If R > 3 Then Set Rng = Range(.Cells(3, "A"), .Cells(R - 1, "C")) Rng.Copy Destination:=.Cells(3, "I") ' write totals Rl = .Cells(.Rows.Count, "I").End(xlUp).Row Set Rng = Range(.Cells(3, "J"), .Cells(Rl, "J")) Rl = Rl + 1 With .Cells(Rl, "I") .Value = "Remaining" .HorizontalAlignment = xlRight .Font.Bold = True End With With .Cells(Rl, "J") .Value = Application.Sum(Rng) .HorizontalAlignment = xlCenter .Font.Bold = True End With With .Cells(Rl, "K") .Value = Application.Sum(Rng.Offset(0, 1)) .HorizontalAlignment = xlCenter .Font.Bold = True End With End If End With End Sub

Private Sub CommandButton1_Click() Dim lr As Long Dim pr As Long With Sheets("Sheet1") lr = .Range("A" & Rows.Count).End(xlUp).Row 'Calculation for Top 10 Countries .Range("A" & (lr - 10) & ":C" & lr).Copy .Range("E3") 'Calculation for Remaining Countries .Range("A3:C" & (lr - 11)).Copy .Range("I3") pr = .Range("A3:C" & (lr - 11)).Rows.Count + 3 .Range("I" & pr).Value = "Remaining" .Range("J" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" .Range("K" & pr).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)" End With End Sub

The code below first sorts the main table by country (hard-coded option), then creates 2 copies of the sorted table in columns E and I sorted descending or ascending (hard-coded option), and deletes the part in each which isn't needed. The user can choose the year by which the ranking is to be determined, and the program allows for more years to be added to the main table and processed without change of code. You may wish to change the name of the worksheet in the code. Option Explicit Private Sub CommandButton1_Click() ' 14 Nov 2017 Dim Ws As Worksheet Dim ClmCount As Long Dim SortYear As Long ' = column in main table Dim SortOrder As XlSortOrder Dim Rng As Range Dim Rl As Long, Rend As Long ' last row Dim R As Long, C As Long Set Ws = Worksheets("Deepak") SortYear = YearToSort(Ws) If SortYear Then ' exit if cancelled Application.ScreenUpdating = False With Ws Rl = .Cells(.Rows.Count, "A").End(xlUp).Row If Rl > 3 Then ' skip, if no list ClmCount = MainTableColumnsCount(Ws) ' === Sorting the main table ' you can sort on another column, in another order ' or skip the sort entirely ' to skip remove these two lines of code Set Rng = Range(.Cells(3, "A"), .Cells(Rl, ClmCount)) SortRange Rng, 1, xlAscending ' sort Main by country (column 1) ' === set the sort order for Lists 1 & 2 here:- SortOrder = xlAscending ' Alt: change for xlDescending SheetSetup Ws, SortYear, SortOrder ' create sorted copies ' List 1: delete all but the top 10 C = ClmCount + 2 R = IIf(SortOrder = xlAscending, 3, 13) Rend = IIf(SortOrder = xlAscending, Rl - 10, Rl) Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1)) Rng.Delete Shift:=xlUp ' List 2: delete the top 10 C = 2 * (ClmCount + 1) + 1 R = IIf(SortOrder = xlAscending, Rl - 9, 3) Rend = IIf(SortOrder = xlAscending, Rl, 12) Set Rng = Range(.Cells(R, C), .Cells(Rend, C + ClmCount - 1)) Rng.Delete Shift:=xlUp ' write totals Rl = .Cells(.Rows.Count, C).End(xlUp).Row With .Cells(Rl + 1, C) .Value = "Remaining" .HorizontalAlignment = xlRight .Font.Bold = True End With For C = (C + 1) To (C + ClmCount - 1) Set Rng = Range(.Cells(3, C), .Cells(Rl, C)) With .Cells(Rl + 1, C) .Value = Application.Sum(Rng) .HorizontalAlignment = xlCenter .Font.Bold = True End With Next C End If End With Application.ScreenUpdating = True End If End Sub Private Sub SortRange(Rng As Range, _ SortColumn As Long, _ SortOrder As XlSortOrder) ' 14 Nov 2017 With Rng.Worksheet.Sort .SortFields.Clear .SortFields.Add Key:=Rng.Columns(SortColumn), _ SortOn:=xlSortOnValues, _ Order:=SortOrder, _ DataOption:=xlSortNormal .SetRange Rng .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub Private Function YearToSort(Ws As Worksheet) As Long ' 14 Nov 2017 ' return the column number of the main table ' return 0 if cancelled Dim Fun As Long Dim Rng As Range Dim UserInput As String Set Rng = Ws.Range(Cells(2, 2), Cells(2, MainTableColumnsCount(Ws))) ' use B2 as default Do UserInput = InputBox("Enter the year to sort by:", _ "Select a year", Rng.Cells(1).Value) If UserInput = "" Then Exit Do On Error Resume Next Fun = Application.Match(CLng(UserInput), Rng, 0) If Err Then MsgBox "There is no data for year " & UserInput & "." & vbCr & _ "Please enter an available year.", _ vbInformation, "Invalid input" UserInput = "" On Error GoTo 0 End If Loop While UserInput = "" YearToSort = Fun + 1 End Function Private Sub SheetSetup(Ws As Worksheet, _ SortYear As Long, _ SortOrder As XlSortOrder) ' 14 Nov 2017 Const Captions As String = "Top 10 countries,All other countries" Dim Rng As Range, SortRng As Range Dim ClmCount As Long Dim Rl As Long ' last row Dim C As Long Dim i As Long With Ws Rl = .Cells(.Rows.Count, 1).End(xlUp).Row ClmCount = MainTableColumnsCount(Ws) C = .UsedRange.Columns.Count If C > ClmCount Then ' delete all existing except main table Set Rng = Range(.Cells(1, ClmCount + 1), .Cells(Rl, C)) Rng.Cells.Delete Shift:=xlUp End If Set Rng = Range(.Cells(1, 1), .Cells(Rl, ClmCount)) ' create two copies of the main table For i = 1 To 2 C = (ClmCount + 1) * i + 1 Rng.Copy Destination:=.Cells(1, C) .Cells(1, C + 1).Value = Split(Captions, ",")(i - 1) Set SortRng = Range(.Cells(3, C), .Cells(Rl, C + ClmCount - 1)) SortRange SortRng, SortYear, SortOrder Next i End With End Sub Private Function MainTableColumnsCount(Ws As Worksheet) As Long ' 14 Nov 2017 Dim Fun As Long Do Fun = Fun + 1 Loop While Len(Ws.Cells(2, Fun).Value) MainTableColumnsCount = Fun - 1 End Function

You could do it with formulas as well. In the G3 cell type: =LARGE(C$3:C$200, ROW()-2) for finding the top country. In F3 and E3 insert: =INDEX(B$3:B$200, MATCH(G3,C$3:C$200,0)) and =INDEX(A$3:A$200, MATCH(G3,C$3:C$200,0)) respectively. Then drag then down to 12th row. You have top 10 now. In the cell K3 type: =IFERROR(LARGE(C$3:C$200, ROW()+8),"") and in J3 and I3: =IFERROR(INDEX(B$3:B$200, MATCH(K3,C$3:C$200,0)),"") and =IFERROR(INDEX(A$3:A$200, MATCH(K3,C$3:C$200,0)),"") Then drag then down several screens. There is less than 200 countries and territories on the world, so it should be enough. If there is no macros, you don'tneed the button, everything will update on fly.

### Align duplicate column in excel at the same time preserving values present in subsequent column

My data is spreaded in many columns. In that, Column A and Column B has identical name (duplicates), while Column C to Q are values related to column B. I want to align column B to Column A while preserving subsequent values as it is. NOTE: My question is very much similar to this one "Align identical data in two columns while preserving values in the 3rd in excel" But in my case I want to preserve more subsequent columns (from C to Q). I played with code given as a solution by #Jeeped in that post but failed. Can I get any help in this regards, I have tried following code: Sub aaMacro1() Dim i As Long, j As Long, lr As Long, vVALs As Variant With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row vVALs = Range("B1:C" & lr) Range("B1:C" & lr).ClearContents For i = 1 To lr For j = 1 To UBound(vVALs, 1) If vVALs(j, 1) = .Cells(i, 1).Value Then .Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j) Exit For End If Next j Next i End With End Sub I have made an attempt to change range("B1:C" & lr) to range ("B1:Q" & lr), but it didnt work. After that I have changed .Resize (1,2) to .Resize (1,3), and it copied two subsequent rows but when i inset a code with .Resize (1,4), didn't work. Hope this edited post helps to answer my question. With best

Based on the code in the original link, should work with any number of columns ... Option Explicit Option Base 1 Sub aaMacro1() Dim i As Long, j As Long, k As Long Dim nRows As Long, nCols As Long Dim myRng As Range Dim vVALs() As Variant With ActiveSheet nRows = .Cells(Rows.Count, 1).End(xlUp).Row nCols = .Cells(1, Columns.Count).End(xlToLeft).Column Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols)) End With nRows = nRows - 1 nCols = nCols - 1 vVALs = myRng.Value myRng.ClearContents For i = 1 To nRows For j = 1 To nRows If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then For k = 1 To nCols myRng.Cells(i, k).Value = vVALs(j, k) Next k Exit For End If Next j Next i End Sub Test input ... Provides this output ...

you can try this Option Explicit Sub AlignDupes() Dim lRow As Long, iRow As Long Dim mainRng As Range, sortRange As Range With ActiveSheet lRow = .Cells(.Rows.Count, 1).End(xlUp).Row Set mainRng = .Range("A1:A" & lRow) Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count) .Sort.SortFields.Clear End With Application.AddCustomList ListArray:=mainRng With sortRange .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal iRow = 1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row Do While iRow <= lRow Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1) .Rows(iRow).Insert iRow = iRow + 1 lRow = lRow + 1 Loop iRow = iRow + 1 Loop End With Application.DeleteCustomList Application.CustomListCount End Sub

### Move cells into 1 row according to column A and Data and Time from Column D

I think this photo should pretty much tell you what I am trying to achieve. I can still try to explain bit. I have on top table 5 column A B C D E Column A is main it contains Num with record for individual numbers it can have up to 8 records. I need to put all record in 1 line by NUM. it is sort by A and D. I just need to move column C based on time it occurred. I just added extra column because I can have up to 8 Non Created and upto 4 Cause Created record.

I am assuming the follwoing The Table one is in Sheet called "Input" The output will be generated in Sheet called "output" which already have the headers in place Paste this code in a module and run it Option Explicit Sub Sample() Dim wsInput As Worksheet, wsOutput As Worksheet Dim wsILrow As Long, wsOLrow As Long, i As Long, c As Long, nc As Long Dim wsIrng As Range, fltrdRng As Range, cl As Range Dim col As New Collection Dim itm Set wsInput = Sheets("Input") Set wsOutput = Sheets("Output") With wsInput wsILrow = .Range("A" & .Rows.Count).End(xlUp).Row Set wsIrng = .Range("A1:E" & wsILrow) With wsIrng .Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("D2") _ , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _ , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _ xlSortNormal End With For i = 2 To wsILrow On Error Resume Next col.Add .Cells(i, 1).Value, Chr(34) & .Cells(i, 1).Value & Chr(34) On Error GoTo 0 Next i End With wsOLrow = 2 With wsOutput For Each itm In col .Cells(wsOLrow, 1).Value = itm wsOLrow = wsOLrow + 1 Next wsOLrow = .Range("A" & .Rows.Count).End(xlUp).Row For i = 2 To wsOLrow With wsInput '~~> Remove any filters .AutoFilterMode = False With wsIrng '<~~ Filter, offset(to exclude headers) .AutoFilter Field:=1, Criteria1:=wsOutput.Cells(i, 1).Value Set fltrdRng = .Offset(1, 0).SpecialCells(xlCellTypeVisible) End With '~~> Remove any filters .AutoFilterMode = False End With '<~~ c is for Cause column and nc is for non cause c = 3: nc = 7 For Each cl In fltrdRng.Cells If cl.Column = 3 And Len(Trim(cl.Value)) <> 0 Then If InStr(1, cl.Value, "Cause", vbTextCompare) Then .Cells(i, c).Value = wsInput.Cells(cl.Row, 3).Value c = c + 1 ElseIf InStr(1, cl.Value, "Non", vbTextCompare) Then .Cells(i, nc).Value = wsInput.Cells(cl.Row, 3).Value nc = nc + 1 End If .Cells(i, 2).Value = wsInput.Cells(cl.Row, 2).Value .Cells(i, 15).Value = wsInput.Cells(cl.Row, 5).Value End If Next Next i End With End Sub Screenshot Input Sheet Output Sheet Note: Any future changes to the structure has to be incorporated in the code as well.