Get Percentage on Basis of Text Fields

[sg2209]

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


'Sub Delete_Range_EntireColumn()


'Range("A1:O4000").EntireColumn.Delete


'End Sub


Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Sourcewb = ActiveWorkbook


'Copy the ActiveSheet to a new workbook
Sourcewb.Sheets("Combined").Copy
Set Destwb = ActiveWorkbook


'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With


' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "Megha.Verma@genpact.com"
.CC = "Mitesh.Nagar@genpact.com;sangram.rathore1@genpact.com"
.BCC = ""
.Subject = "Samples"
.Body = "Hi Please find attached"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With


'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr


Set OutMail = Nothing
Set OutApp = Nothing


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[sg2209]

Any luck here please ?