Sub Filter30()
'
'Prg : Filter30
'Author : Markmzz
'Date : 26/06/2011
'Version: 01
'
'Define the macro variables
Dim LastRow, LastCol, LastRowCB, LastColDT As Long
Dim LastColDTF, LastRowB, LastRow30, i As Long
'Disable ScreenUpdating
Application.ScreenUpdating = False
'Select the worksheet
Sheets("Customers").Select
'Determines the last column in the list of customers
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'Determines the last row in the list of customers
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'Create the column of random number (Rnd)
Cells(1, LastCol + 1).Value = "Rnd"
Range(Cells(2, LastCol + 1), Cells(LastRow, LastCol + 1)).Formula = _
"=RandBetween(1,CountA(A:A))"
LastCol = LastCol + 1
'Copy the label Branch for two cells two columns
'to the right of the list of customers
Cells(1, 2).Copy _
Destination:=Range(Cells(1, LastCol + 2), Cells(1, LastCol + 3))
'Create a list of unique branch
Range(Cells(1, 1), Cells(LastRow, LastCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cells(1, LastCol + 2), _
Unique:=True
'Determines the last row in the list of branchs
LastRowB = Cells(Rows.Count, LastCol + 2).End(xlUp).Row
'Sort, in ascending order, the list of branchs
Range(Cells(2, LastCol + 2), Cells(LastRowB, LastCol + 2)).Sort _
Key1:=Cells(1, LastCol + 2), _
Order1:=xlAscending
'Define the last column with data
LastColDT = LastCol + 3
'Browse for the list of branchs
For i = 2 To LastRowB
'Copy the current branch to the cell of criteria
Cells(i, LastCol + 2).Copy _
Destination:=Cells(2, LastCol + 3)
'Filter the list of customers by the current branch in
'the criteria area
Range(Cells(1, 1), Cells(LastRow, LastCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cells(1, LastColDT + 2), _
CriteriaRange:=Range(Cells(1, LastCol + 3), Cells(2, LastCol + 3))
'Determines the last column in the list of customers & branchs
LastColDTF = Cells(1, Columns.Count).End(xlToLeft).Column
'Determines the last row in the list of customers & branchs
LastRowCB = Cells(Rows.Count, LastColDTF).End(xlUp).Row
'Sort, in ascending order, the list of customers & branchs
'by the field Rnd
Range(Cells(2, LastColDT + 2), Cells(LastRowCB, LastColDTF)).Sort _
Key1:=Cells(1, LastColDTF), _
Order1:=xlAscending
'Delete the column of the field Rnd
Cells(1, LastColDTF).EntireColumn.Delete
LastColDTF = LastColDTF - 1
'Determines the number of rows of 30%
LastRow30 = Round((LastRowCB - 1) * 0.3, 0)
'Delete the data of the row large then 30%
Range(Cells(LastRow30 + 2, LastColDT + 2), Cells(LastRowCB, LastColDTF)).Clear
LastColDT = LastColDTF
Next i
'Delete the columns of helper (Rnd and criteria)
Range(Cells(1, LastCol), Cells(1, LastCol + 3)).EntireColumn.Delete
'Enable ScreenUpdating
Application.ScreenUpdating = True
End Sub
