Excel VBA replace selection with blank value - vba

I have three columns, one of them having all the staff list IDs, the second is having Front-Line staff IDs, The third is having the Back-office staff IDs, sometimes we change the task to some of them, to work in the different field, So His Staff ID has to disappear from Front-Line col and appear in Back-Office col instead. and Vice-Versa, and this will be done by selecting some of Column A staff, then it will loop through Col B and remove selection value(If found), then add these selected cells to Col B.
The same when we normalize, we select some staff from Col A, It should remove the staff IDs from Col B and add it to col C
All Staff | Front-line | Back-Office
15348 | 15348 | 15344
15347 | 15347 | 15345
15345 |
15344 |
What I've achieved so far.
Excuse me if my codes looks a little bit complex, that's the only way I know.
Dedicate Button (Dedicating 1st Col staffs to work as Back-office)
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 8).Select
Cells(firstempty, 8).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("H" & i).Value = .Range("L" & j).Value Then
found = True
End If
End With
Next j
If found = False Then
dedlist = dedlist + 1
With Sheets("StaffList")
.Range("L" & dedlist).Value = .Range("H" & i).Value
End With
End If
found = False
Next i
' ActiveSheet.Range("$H$1:$H$500").RemoveDuplicates Columns:=1, Header:=xlYes
Range("A1").Select
Normalize Button (Normalizing 2nd Col staffs to get back working as Front-Line)
Dim CompareRange As Variant, x As Variant, y As Variant
Dim rng As Range
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 13).Select
Cells(firstempty, 13).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("M" & i).Value = .Range("L" & j).Value Then
.Range("H" & j).Value = ""
End If
End With
Next j
Next i
Range("A1").Select

This is the VBA implementation of the suggestion in comment:
Option Explicit
Public Sub UpdateStaffTasks()
Const FRNT = "Front-line", BACK = "Back-Office"
Dim selRow As Variant, lrSelRow As Long, ws As Worksheet, i As Long, j As Long
Dim usdRng As Variant, lrUsdRng As Long, red As Long, blu As Long
If Selection.Cells.Count = 1 And Selection.Row = 1 Then Exit Sub
Set ws = Selection.Parent
selRow = GetSelRows(Selection): lrSelRow = UBound(selRow): red = RGB(256, 222, 222)
usdRng = ws.UsedRange: lrUsdRng = UBound(usdRng): blu = RGB(222, 222, 256)
For i = 0 To lrSelRow
For j = i + 2 To lrUsdRng
If j = Val(selRow(i)) Then
If Len(usdRng(j, 1)) > 0 And Len(usdRng(j, 2)) > 0 Then
usdRng(j, 2) = IIf(usdRng(j, 2) = FRNT, BACK, FRNT)
With ws.Cells(j, 1).Resize(, 2).Interior
.Color = IIf(usdRng(j, 2) = FRNT, red, blu)
End With
Exit For
End If
End If
Next
Next
Selection.Parent.UsedRange = usdRng
End Sub
Public Function GetSelRows(ByRef selectedRange As Range) As Variant
Dim s As Variant, a As Range, r As Range, result As Variant
If selectedRange.Cells.Count > 1 Then
For Each a In selectedRange.Areas
For Each r In a.Rows
If r.Row > 1 And InStr(s, r.Row) = 0 Then s = s & r.Row & " "
Next
Next
GetSelRows = Split(RTrim$(s)): Exit Function
Else
GetSelRows = Array(selectedRange.Row): Exit Function
End If
End Function
Before and After:

Related

Format Code to Output New Rows for Number Expansion

I have this code
Sub ExpandRanges()
Dim X As Long, CG As Variant, Rng As Range, Cell As Range
Dim Series As String, CommaGroups() As String, DashGroups() As String
Set Rng = Range(Range("H2"), Cells(Rows.Count, "H").End(xlUp))
For Each Cell In Rng
CommaGroups = Split(Cell, ",")
For Each CG In CommaGroups
DashGroups = Split(CG, "-")
For X = DashGroups(0) To DashGroups(UBound(DashGroups))
Series = Series & ", " & X
Next
Next
Cell.Offset(, 1).Value = Mid(Series, 3)
Series = ""
Next
End Sub
That gives me and output of:
Can anyone reformat the code to where it creates a new row for each number that is expanded from the range? Rather than expanding them out into a new column to where I have to separate them again manually.
I would like for it to look like this (referring to the first range)
Try this:
EDIT: Fixed
Sub ExpandRanges()
Dim X As Long, CG As Variant, Rng As Range, Cell As Range
Dim Series As String, CommaGroups() As String, DashGroups() As String
Dim j As Long, lastrow As Long, newrow as Long
j = 0
lastrow = Cells(Rows.Count, "H").End(xlUp).Row
newrow = InputBox("What is the row number of your new range?")
Set Rng = Range(Range("H" & newrow), Range("H" & lastrow))
For Each Cell In Rng
CommaGroups = Split(Cell, ",")
For Each CG In CommaGroups
DashGroups = Split(CG, "-")
For X = DashGroups(0) To DashGroups(UBound(DashGroups))
If j = 0 Then j = Split(Cell.Address, "$")(2)
Rows(j + 1 & ":" & j + 1).Insert Shift:=xlDown
Cells(j, 9).Value = X
Range("C" & j + 1 & ":H" & j + 1).Value = Range("C" & j & ":H" & j).Value
j = j + 1
Next
Next
Next
'Band-aid solution
lastrow = Cells(Rows.Count, "H").End(xlUp).Row
Range("C" & lastrow & ":H" & lastrow).ClearContents
End Sub

Slow VBA Code optimisation

I´m pretty new to VBA and since it´s making my job so much easier I try to write some codes from time to time and everything works fine except for this one, I already tried with the Screen Updating and the Status Bar method but it´s still very slow. Any ideas on how it coul be improved? Thnak you
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1
Do Until i > LastRow
If Range("B" & i) = Range(B & i + 1) Then
Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
Range("A" & i + 1).EntireRow.Delete
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
This does what your code does; i tested with 1k rows of data and it was faster then your code. (Updated with ja72's input)
Dim i As Long
Dim LastRow As Long
If Range("B1") = Range("B2") Then
Rows(1).Copy
Rows(1).Insert Shift:=xlDown
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
Cells(1, 12).Resize(, 5).FillRight
End If
Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value
Rows(2 & ":" & Rows.Count).Delete
The code below first addresses the issue of string math for the range picking. Instead of .Range("A" & i) it best to use .Offset() or .Cells() instead. Additionally it makes it explicit that we are dealing with values and not ranges when the math takes place. It is recommended to always type .Value where it is implied.
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range, g As Range
' Set the start of the optimization loop
Set r = Range("B1")
' While still inside the data
Do While r.Row <= LastRow
' Check this value with value of next row
If r.Value = r.Offset(1, 0).Value Then
Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
Go from "L" to "Q"
For i = 1 To 6
'Add values one by one with row below
g.Offset(0, i - 1).Value = _
g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
Next i
r.Offset(1, 0).EntireRow.Delete
LastRow = LastRow - 1
End If
' Move to next row
Set r = r.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Depending on the total amount of data, it will be way faster to load all the data into memory and process it with VBA arrays only to be returned back in the end to the worksheet.
The following code should be orders of magnitude faster.
Sub DW2()
Dim i As Long, j As Long, i_out As Long, i_next As Long
Dim LastRow As Long, ValCol As Long, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ValCol = Cells(, "L").Column
LastCol = Cells(, "Q").Column
Dim r_data As Range
' Reference all the data (filled rows, and 17 columns "A:Q")
Set r_data = Range("A1").Resize(LastRow, LastCol)
' x is input data, y as output data
Dim x() As Variant, y() As Variant
' Copy all the table cells into memory
x = r_data.Value
' Create an empty array at least the same size
ReDim y(1 To LastRow, 1 To LastCol)
' i_out is index for output
i_out = 1
' i is index for input
For i = 1 To LastRow
' Debug.Print "Row"; i, "into Row:"; i_out
'Copy all values first from current row
For j = 1 To LastCol
y(i_out, j) = x(i, j)
Next j
' Index i_next peeks at the next row
i_next = i + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
' Check with value match on 2nd column "B"
Do While x(i, 2) = x(i_next, 2)
'Add up values in columns 11 through 17
For j = ValCol To LastCol
y(i_out, j) = y(i_out, j) + x(i_next, j)
Next j
' Peek at subsequent rows also
i_next = i_next + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
Loop
' Advance i if rows were skipped
i = i_next - 1
' Advance i_out
i_out = i_out + 1
Next i
' Clear all table cells
r_data.ClearContents
' Overwrite with the optimized values
r_data.Resize(i_out - 1, LastCol).Value = y
End Sub
Edit: Now tested for robustness when matching rows exist in the end of the data

Excel VBA copy from one sheet to other sheets specific cells based on criteria

I am trying to copy from Sheet1, specific rows when on that row a specific cell has status "DONE" selected to say, and a second criteria after "DONE" is to check if on the same row, another cell has also a specific value. After that, copy the rows found each on specific sheet, checking destination if duplicates are found.
I have managed until now to copy from Sheet1 to the other based on the 2 criteria (old school with IF, I tried with autofilter but I didn't manage to do it) but I am having a hard time preventing duplicates to be copied to the other sheets.
I tried everything, value checking based on first sheet with Range, writing a macro for each sheet so it prevents duplicates, nothing worked and i am stuck on this.
Another problem with below code is that after hitting Update button multiple times, it doesn't duplicate all found rows, but only the first one found, and also inserts some empty rows in between and I don't understand the reason for that.
Here is the code:
Private Sub CommandButton1_Click()
Dim LastRow As Long
Dim i As Long, j As Long, k As Long, j1 As Long, k1 As Long, j_last As Long,
k_last As Long
Dim a As Long, b As Long
Dim ActiveCell As String
With Worksheets("PDI details")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo ATMC")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo ATMC Courtesy")
k = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo SHJ")
j1 = .Cells(.Rows.Count, "A").End(xlUp).Row
k1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo AD")
a = .Cells(.Rows.Count, "A").End(xlUp).Row
b = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (j)
For i = 5 To LastRow
With Worksheets("PDI details")
If .Cells(i, 20).Value <> "" Then
If .Cells(i, 20).Value = "DONE" Then
If .Cells(i, 11).Value = "ATMC DEMO" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC").Range("D4") Then
Worksheets("Demo ATMC").Range("A" & j) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC").Range("B" & j) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC").Range("C" & j) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC").Range("D" & j) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC").Range("F" & j) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC").Range("G" & j) = Worksheets("PDI details").Range("I" & i).Value
End If
End If
If .Cells(i, 11).Value = "ATMC COURTESY" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC Courtesy").Range("D4")
Then
Worksheets("Demo ATMC Courtesy").Range("A" & k) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC Courtesy").Range("B" & k) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC Courtesy").Range("C" & k) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC Courtesy").Range("D" & k) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC Courtesy").Range("F" & k) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC Courtesy").Range("G" & k) = Worksheets("PDI details").Range("I" & i).Value
k = k + 1
End If
End If
End If
End If
End With
Next i
End Sub
I couldn't test the code suggested below but I believe that it does what you wish it to do.
Option Explicit
Private Sub CommandButton1_Click()
' 23 Dec 2017
Dim WsPdi As Worksheet
Dim WsAtmc As Worksheet, WsCourtesy As Worksheet
Dim R As Long, Rl As Long ' row / lastrow "PDI details"
Set WsPdi = Worksheets("PDI Detail")
Set WsAtmc = Worksheets("Demo ATMC")
Set WsCourtesy = Worksheets("Demo ATMC Courtesy")
Application.ScreenUpdating = False
With WsPdi
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 5 To Rl
If .Cells(R, 20).Value = "DONE" Then
Select Case .Cells(R, 11).Value
Case "ATMC DEMO"
TransferData WsPdi, WsAtmc, R
Case "ATMC COURTESY"
TransferData WsPdi, WsCourtesy, R
End Select
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Sub TransferData(WsSource As Worksheet, _
WsDest As Worksheet, _
R As Long)
' 23 Dec 2017
Dim Csource() As String
Dim Rn As Long ' next empty row in WsDest
Dim C As Long
Csource = Split(",A,E,F,G,,H,R", ",")
With WsDest
If WsSource.Cells(R, 7).Value <> .Cells(4, "D").Value Then
Rn = .Cells(.LastRow, "A").End(xlUp).Row + 1
For C = 1 To 7 ' columns A to G
If C <> 5 Then
.Cells(Rn, C).Value = WsSource.Cells(R, Csource(C)).Value
End If
Next C
End If
End With
End Sub

Moving to the next column

Can anybody please help me figure out my problem?
I have this code that I would like to move to the next column if the condition is not met.I'm stuck and don't know where to proceed.
Dim lrow3, lrow1 as long
dim dDate as Date
dim yrNum, j as Integer
dDate = Format(Now(),"mm/dd/yyyy")
lrow3 = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
lrow1 = Sheets("Sample").Cells(Rows.count, 2).End(xlUp).Row
for j = 2 to lrow1
For yrNum = 1 To 100
If DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) >= DateValue(dDate) And _
DateValue(Format(Range("R" & j).Value, "mm/dd/yyyy")) <= DateValue(dDate) Then
ActiveSheet.Range("D" & lrow3 + 1).Value = Range("T" & j).Value
ActiveSheet.Range("E" & lrow3 + 1).Value = Range("U" & j).Value
Exit For
Else
Range("Q" & j) = ActiveCell
Range("Q" & j) = ActiveCell.Offset(0, 9)
'after executing this is I have to set this offsetted cell to be the active one
'on which i will be referring in the next loop
End If
Next yrNum
next j
In the snippet, if the value in Q & j does not met the requirements, then i have to check the 9th letter after Q which is Z and so on.
By the way what I'm comparing on this are date values in the cell.
A few observations
dDate = Format(Now(),"mm/dd/yyyy") is the same as dDate = Date
DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) is the same asDateValue(Range("Q" & j).Value)`
You are starting in column Q and if the conditions are not meet you move over 9 columns and check again. You do this 100 times. The final column is column 917(column letter code AIG)
Sub RefactoredCode()
Dim lrow3, lrow1 As Long
Dim DateRange As Range
Dim wsSample As Worksheet
Dim yrNum, j As Integer, iOffset As Integer
Set wsSample = Worksheets("Sample")
lrow3 = Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = wsSample.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To lrow1
For yrNum = 1 To 100
iOffset = (yrNum * 9) - 9
Set DateRange = wsSample.Cells(j, "Q").Offset(0, iOffset)
If DateValue(DateRange.Value) >= Date And _
DateValue(DateRange.Offset(0, 1).Value) <= Date Then
lrow3 = lrow3 + 1
Range("D" & lrow3).Value = wsSample.Cells(j, "T").Offset(0, iOffset).Value
Range("E" & lrow3).Value = wsSample.Cells(j, "U").Offset(0, iOffset).Value
Exit For
End If
Next yrNum
Next j
End Sub

VBA Special Copy loop

Does anyone know how i could expand this code to include 2 more columns of data in its pasting. (columns C and D)
Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
MyArray(j) = Range("A" & i).Value
j = j + 1
k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
End Sub
Currently the code separates this:
TREVDAN 2
CENTRAL 3
GAL FAB 1
Into this:
TREVDAN 1
TREVDAN 1
CENTRAL 1
CENTRAL 1
CENTRAL 1
GAL FAB 1
Try this:
Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
ReDim ArrayC(1 To ArrayLength) As String 'new
ReDim ArrayD(1 To ArrayLength) As String 'new
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
MyArray(j) = Range("A" & i).Value
ArrayC(j) = Range("C" & i).Value 'new
ArrayD(j) = Range("D" & i).Value 'new
j = j + 1
k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
For Each MyCell In Range("C1:C" & ArrayLength) 'new
MyCell.Value = ArrayC(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
For Each MyCell In Range("D1:D" & ArrayLength) 'new
MyCell.Value = ArrayD(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
End Sub
This is what I landed up doing:
Sub Splitting()
'splitting up rows
'quantity column: AI
'Data columns: AF,AG,AH,AJ
firstrow = Range("AF2:AJ2")
Dim i As Long, k As Long
Dim j As Long: j = 1
'Next line of code is setting array length equal to the quanity column sum
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("AI:AI"))
'Redimentioning all data array to have this fixed array length
ReDim First_Array(1 To ArrayLength) As String
ReDim Second_Array(1 To ArrayLength) As String
ReDim Third_Array(1 To ArrayLength) As String
ReDim Fourth_Array(1 To ArrayLength) As String
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("AI" & i).Value
First_Array(j) = Range("AF" & i).Value
Second_Array(j) = Range("AG" & i).Value
Third_Array(j) = Range("AH" & i).Value
Fourth_Array(j) = Range("AJ" & i).Value
j = j + 1
k = k + 1
Loop
Next i
'Data Placement
For Each MyCell In Range("AF2:AF" & ArrayLength)
MyCell.Value = First_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AG2:AG" & ArrayLength)
MyCell.Value = Second_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AH2:AH" & ArrayLength)
MyCell.Value = Third_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AJ2:AJ" & ArrayLength)
MyCell.Value = Fourth_Array(MyCell.Row())
Next MyCell
'bring back first row
Range("AF2:AJ2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("AF3").Select
ActiveSheet.Paste
Range("Af1").Select
Range("AF2:AJ2") = firstrow
'replace quantity column with 1
For Each MyCell In Range("AI2:AI" & ArrayLength + 1)
MyCell.Value = 1
Next MyCell
End sub
Personally I would do it without the arrays...
Sub VBA_Special_Copy_Loop()
Dim lngLastRow As Long, rngSource As Range, iMax As Integer
Dim x As Integer, y As Integer, WF As Object
Set WF = Application.WorksheetFunction
lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row
Columns("AG").Insert
With Range("AG1").Resize(lngLastRow)
.Formula = "=ROW()"
.Value = .Value
.Cells(1) = "Row"
End With
Set rngSource = Range("AF1").Resize(lngLastRow, 6)
iMax = WF.Max(rngSource.Columns(5))
For x = 2 To iMax
If WF.CountIf(rngSource.Columns(5), x) > 0 Then
rngSource.AutoFilter Field:=5, Criteria1:=x
For y = 2 To x
rngSource.Copy Range("AF1").Offset(lngLastRow)
Range("AF1").Offset(lngLastRow).Resize(, 6).Delete Shift:=xlUp
lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row
Next y
End If
Next x
rngSource.AutoFilter
Range("AF2").Resize(lngLastRow - 1, 6).Sort Key1:=Range("AG1")
Columns("AG").Delete
End Sub