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.

Resources