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
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