PDA

View Full Version : How to get Percentage



sg2209
11-19-2018, 12:45 AM
hi Friends,

please help i am not very much familiar with VBA

Need help with the below code


this is being used for Random Sample picking tool, Currently set to pick 10 accounts for evry users, now i need to pick 10% of Users productivity, the higjlighted part shows slecting 10 and from Column U , Countif formula is set there.


Users are in Column G, what changes should i do so it take 10% of users.


For Example User A has worked 50 accts it should pick 5 accounts
User B has worked 90 accts it should pcik 9 accounts
User C has worked 75 accts it should pick 7 accounts.




Please help


Sub Indian_jugaad()
Dim ws As Worksheet


msgboxValue = MsgBox("This VBA will Delete all worksheets, pleae confirm ", vbOKCancel)


If msgboxValue = vbOK Then


'Selection.AutoFilter
Sheet1.Activate
Row = Range("A700000").End(xlUp).Row
col = Range("zz1").End(xlToLeft).Column
Application.ScreenUpdating = False
Application.DisplayAlerts = False


' Delete sheets




For Each ws In Worksheets
If ws.Name <> "Do-Not-Delete" Then
ws.Delete
End If
Next




' Ramdom sampling




Range("T2").Select
ActiveCell.FormulaR1C1 = "=RAND()"
Range("u2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R2C7:RC[-14],RC[-14])"
Range("t2:u2").Copy

Range("T" & Row).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste

Range("t1").Select



Sheet1.Sort.SortFields.Clear
Sheet1.Sort.SortFields.Add Key:=Range( _
"t1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With Sheet1.Sort
.SetRange Range("A2:U" & Row)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Columns("T:U").Select
Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False




'Remove Duplicates from Columns
'Columns(9).RemoveDuplicates Columns:=Array(1)






' Extracting result








Range("u1").Select
Selection.AutoFilter
Selection.End(xlToRight).Select
ActiveSheet.Range("$A$1:$U$" & Row).AutoFilter Field:=21, Criteria1:="<=10", Operator:=xlAnd
ActiveSheet.UsedRange.Select
Range("A1").Activate
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = "tmp"



Columns("G:G").Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = "a"
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$10063").RemoveDuplicates Columns:=1, Header:=xlYes




' Creating sheets




For Each i In Sheets("a").Range("a2:a" & Sheets("a").Range("a50000").End(xlUp).Row)


Sheets("tmp").Activate


Row1 = Range("A700000").End(xlUp).Row
Columns("T:U").Delete
ActiveSheet.Range("a1").Select
Selection.AutoFilter
Selection.End(xlToRight).Select
ActiveSheet.Range("$A$1:$S$" & Row1).AutoFilter Field:=7, Criteria1:=i
ActiveSheet.UsedRange.Select
Range("A1").Activate
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = i


Next


Sheets("a").Delete
Sheets("tmp").Delete




Else
MsgBox "You have cancelled all the commands"
End If




Sheet1.Activate
Selection.AutoFilter


Sheet1.Range("U1").Select


MsgBox "Thanks All Done"


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub Combine()
Dim J As Integer
On Error Resume Next
Range("A1:U4000").EntireColumn.Delete
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub