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