• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need help with loop entry

S

salviakshay

New Member
Hi All,

I am trying to create a radom sampler for selecting random cases for audit, attached si the macro created.

Within this macro i am unable to add the loop entry to ensure that the random formula is applied to the last entry in the 1st column.

Kindly assist
 

Attachments

  • Random Sampler.xlsm
    19.5 KB · Views: 1
I think this is what you want, in that the problem was figuring out where the last row of data was. There was a lot of sorting going on in your macro with no comments, but I'm guessing the idea is to apply a random number in col O, sort on that value, and then filter.
Code: 
Sub Sample()
Dim lastRow As Long
Application.ScreenUpdating = False

'Where is the last row of data?
With ActiveSheet
    .AutoFilterMode = False
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Apply the formula
With Range("O2:O" & lastRow)
    .Formula = "=RAND()"
    .Copy
    .PasteSpecial xlPasteValues
End With

Application.CutCopyMode = False

'Add sort fields
With ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields
    .Clear
    .Add Key:=Range("O2:O" & lastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With

'Apply sort
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A1:O" & lastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'Re-filter data
ActiveSheet.Range("$A$1:$O$" & lastRow).AutoFilter Field:=10, Criteria1:="=Closed" _
    , Operator:=xlOr, Criteria2:="=Reserved"

Application.ScreenUpdating = True
End Sub
 
Thanks Luke, this works perfect....I have made certain ammendments to suit the sort prefrences.

One other thing in addition to the above macro, is there a entry to select the data matching two criteria and pasting it to a diffrent sheet.

For eg in the attached sheet post running macro 1, macro 2 should do following:-

Column H is going to be the agent list, it should select the first entry for every unique combination of column b and column K (combined) and paste it to a new sheet.

I have ammended the sample sheet, the macro should copy result of row 2, (ignore row 3 as details in column b and k match earlier entry), copy result of row 4 and 6 ( as the combination of b and k is diffrent ) do so for other agents and paste it to a new sheet.

Regards
 

Attachments

  • Random Sampler.xlsm
    19.5 KB · Views: 0
Each agent getting their own sheet, or each unique combination getting its own sheet?
 
Here ya go, two different macros.
 

Attachments

  • Random Sampler 2 Macros.xlsm
    21.7 KB · Views: 0
Hi Luke,

How do i edit the last row entry to copy the data from range A2 to last data of column E and paste it to a new sheet. currently the code reads data in the sheet only for column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
 
If you want it to go till last row in col E, we can set the variable via
Code: 
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
Is that what you mean?
 
Ah, that would be in the CopyAgents macro then, not the first one. New macro, with one line changed (marked with comment)
Code: 
Sub CopyAgents()
Dim strName As String
Dim strCombo As String
Dim ws As Worksheet
Dim rngAgents As Range
Dim c As Range

Application.ScreenUpdating = False

'Initialize values
strCombo = ""
strName = ""

With ActiveSheet
    Set rngAgents = Intersect(.AutoFilter.Range.Offset(1), Range("H:H")).SpecialCells(xlCellTypeVisible)
    If rngAgents Is Nothing Then
        MsgBox "No visible rows"
        Exit Sub
    End If
    Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    ws.Name = "Detail Info"
    For Each c In rngAgents
        If c.Value <> "" Then
            If c.Value <> strName Then
                'New Agent
                strName = c.Value
                strCombo = ""
            End If
            If c.Offset(, -6).Value & c.Offset(, 3).Value <> strCombo Then
                'New Combination
                'THIS IS THE LINE THAT CHANGED
                Range(Cells(c.Row, "A"), Cells(c.Row, "E")).Copy ws.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                strCombo = c.Offset(, -6).Value & c.Offset(, 3).Value
            End If
        End If
    Next c
End With
Application.ScreenUpdating = True
End Sub
 
Hi Luke sorry if i sound stupid but i am trying to add the modifed code to following code, after the pivot refresh the next code should copy the data from a2 to end of E and paste it to a new workbook

Sub Random_Sampler_v2()
'
' Random_Sampler_v2 Macro
'
With ActiveSheet
.AutoFilterMode = False
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Apply the formula
With Range("m2:m" & lastRow)
.Formula = "=RANDBETWEEN(0,99999999999)"
End With
Sheets("Pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
 
Here's where I'd start to learn more about VB:
http://chandoo.org/forum/threads/vba-tutorial-3-parts-pdf.14544/

http://chandoo.org/wp/excel-vba/videos/

Good compilation of free videos/tutorials

As for the code question, rather than merge the two, you can leave the Copy macro separate, and call it from the 1st macro like so:
Code: 
Sub Random_Sampler_v2()
'
' Random_Sampler_v2 Macro
'
With ActiveSheet
    .AutoFilterMode = False
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Apply the formula
With Range("m2:m" & lastRow)
    .Formula = "=RANDBETWEEN(0,99999999999)"
End With
Sheets("Pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
'Call our other macro
Call CopyAgents
End Sub

Sub CopyAgents()
Dim strName As String
Dim strCombo As String
Dim ws As Worksheet
Dim wb As Workbook
Dim rngAgents As Range
Dim c As Range

Application.ScreenUpdating = False

'Initialize values
strCombo = ""
strName = ""

With ActiveSheet
    Set rngAgents = Intersect(.AutoFilter.Range.Offset(1), Range("H:H")).SpecialCells(xlCellTypeVisible)
    If rngAgents Is Nothing Then
        MsgBox "No visible rows"
        Exit Sub
    End If
    Set wb = Application.Workbooks.Add
    Set ws = wb.Worksheets(1)
    ws.Name = "Detail Info"
    For Each c In rngAgents
        If c.Value <> "" Then
            If c.Value <> strName Then
                'New Agent
                strName = c.Value
                strCombo = ""
            End If
            If c.Offset(, -6).Value & c.Offset(, 3).Value <> strCombo Then
                'New Combination
                .Range(.Cells(c.Row, "A"), .Cells(c.Row, "E")).Copy ws.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                strCombo = c.Offset(, -6).Value & c.Offset(, 3).Value
            End If
        End If
    Next c
End With
Application.ScreenUpdating = True
End Sub
 
Last edited:
Hi Luke,

I have attached the sample file, above code was giving me error while calling the second code.

In the attached file, the second macro should copy the details from "pivot" sheet starting from a2 till E last row and paste it to a new workbook
 

Attachments

  • Randomizer.xls
    52 KB · Views: 0
With a PivotTable, you've compeltely changed the layout of the data, and we now have spaces introduced. Where are the agents? Which columns are we checking if they match? Or, if we're no longer doing that, and it's literally a straight copy, then macro is shortened to:
Code: 
Sub Random_Sampler_v2()
Dim lastRow As Long
Dim ws As Worksheet
Dim wb As Workbook
' Random_Sampler_v2 Macro

Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Input")
    .AutoFilterMode = False
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Apply the formula
    .Range("m2:m" & lastRow).Formula = "=RANDBETWEEN(0,99999999999)"
End With

ThisWorkbook.Worksheets("Pivot").PivotTables(1).PivotCache.Refresh
'Call our other macro
Set wb = Application.Workbooks.Add
Set ws = wb.Worksheets(1)
ws.Name = "Detail Info"

'Don't care about logic, just copy info
With ThisWorkbook.Worksheets("Pivot")
    Intersect(.Range("A2", .Cells(.Rows.Count, "E").End(xlUp)), .UsedRange).Offset(1).Copy ws.Range("A1")
End With
Application.ScreenUpdating = True
End Sub
 
HI Luke, sorry i forgot to mention that the copy agent logic was excluded. it was a bit confusing when the randomizer was used. i found a better way of doing it through PIVOT in chandoo tutorial http://chandoo.org/wp/2014/01/31/how-to-select-a-random-sample-from-all-your-data/.

The above macro works great now and suits the requirement. thank you for your prompt assistance in the query.

PS:- the article provided by you on tutorials is great
 
Hi luke,

In addition to the attached earlier code, i am trying to have the automated email functionality, i found a code from some post (by you :)) and used the following to achive this. however in the earlier macro the new workbook is being created with a new name how do i edit the macro to send the new workbook as an attachment. (I have xxx the email address purposly)

Code: 
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
  Dim OutApp As Object
  Dim OutMail As Object
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  On Error Resume Next
  With OutMail
  .to = "[EMAIL]xxx@xxx.com[/EMAIL]"
  .CC = "[EMAIL]xxx@xxx.com[/EMAIL]"
  .BCC = ""
  .Subject = "Evaluations for Today"
  .Body = "Hi Team"
  .Attachments.Add ActiveWorkbook.FullName
  'You can add other files also like this
  '.Attachments.Add ("C:\test.txt")
  .Send  'or use .Display
  End With
  On Error GoTo 0
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
 
Not quite sure what the status/layout of the other macros currently, but here's a structure you could mimic to email a newly created workbook.
Code: 
Sub ExampleCode()
'This is just to show how to call the 2nd macro
Dim ws As Workbook

'So, we've create a new workbook, how to email it? Know that we need to save the file
'so you'll need to come up with some sort of naming system already
Set wb = Workbooks.Add
wb.SaveAs "C:\Test.xlsx"

'We then call the emailing macro, passing it the full file name
'so it can attach it
Call Mail_workbook_Outlook_1(wb.FullName)

End Sub

Sub Mail_workbook_Outlook_1(fileName As String)
'Argument added, so we must now pass along the file name
'Working in Excel 2000-2013
 Dim OutApp As Object
  Dim OutMail As Object
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  On Error Resume Next
  With OutMail
  .to = "[EMAIL]xxx@xxx.com[/EMAIL]"
  .CC = "[EMAIL]xxx@xxx.com[/EMAIL]"
  .BCC = ""
  .Subject = "Evaluations for Today"
  .Body = "Hi Team"
  .Attachments.Add fileName
  'You can add other files also like this
 '.Attachments.Add ("C:\test.txt")
 .Send  'or use .Display
 End With
  On Error GoTo 0
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
 
Hi Luke,

So what i am trying to do is post running following code

Code: 
Sub Random_Sampler_Final()
Dim lastRow As Long
Dim ws As Worksheet
Dim wb As Workbook
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Input")
  .AutoFilterMode = False
  lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  'Apply the formula
  .Range("m2:m" & lastRow).Formula = "=RANDBETWEEN(0,99999999999)"
End With
ThisWorkbook.Worksheets("Pivot").PivotTables(1).PivotCache.Refresh
'Call our other macro
Set wb = Application.Workbooks.Add
Set ws = wb.Worksheets(1)
ws.Name = "Detail Info"
With ThisWorkbook.Worksheets("Pivot")
  Intersect(.Range("A2", .Cells(.Rows.Count, "E").End(xlUp)), .UsedRange).Offset(1).Copy ws.Range("A1")
End With
Application.ScreenUpdating = True
End Sub
The new workbook should be email to specific email address, currently the listed code is emailing the workbook from which the pivot is copy pasted and not the new workbook[/CODE]
 
How's this? I proposed naming the extracted file with a date stamp, but change it if needed.
Code: 
Sub Random_Sampler_Final()
Dim lastRow As Long
Dim ws As Worksheet
Dim wb As Workbook
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Input")
  .AutoFilterMode = False
  lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  'Apply the formula
.Range("m2:m" & lastRow).Formula = "=RANDBETWEEN(0,99999999999)"
End With
ThisWorkbook.Worksheets("Pivot").PivotTables(1).PivotCache.Refresh
'Call our other macro
Set wb = Application.Workbooks.Add
Set ws = wb.Worksheets(1)
ws.Name = "Detail Info"
With ThisWorkbook.Worksheets("Pivot")
  Intersect(.Range("A2", .Cells(.Rows.Count, "E").End(xlUp)), .UsedRange).Offset(1).Copy ws.Range("A1")
End With

Dim fName As String
'CHANGE THIS NEXT PART
'What to name attachment
fName = ThisWorkbook.Path & "\Extract_" & Format(Date, "yyyymmdd") & ".xlsx"
wb.SaveAs fName
Call Mail_workbook_Outlook_1(wb.FullName)
Application.ScreenUpdating = True
End Sub

Sub Mail_workbook_Outlook_1(fileName As String)
'Argument added, so we must now pass along the file name
'Working in Excel 2000-2013
Dim OutApp As Object
  Dim OutMail As Object
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  On Error Resume Next
  With OutMail
  .to = "xxx@xxx.com"
  .CC = "xxx@xxx.com"
  .BCC = ""
  .Subject = "Evaluations for Today"
  .Body = "Hi Team"
  .Attachments.Add fileName
  'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send  'or use .Display
End With
  On Error GoTo 0
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
 
HI Luke,

This works great i have edited the macro to include current time as well with Format(Now, "dd-mmm-yy h-mm-ss") command.

Will it be possible to save the new created file to a diffrent folder, currently it saves the file in the folder from where the randomizer is being run. what if i need to change the path. how do i edit the fName = ThisWorkbook.Path string
 
You must log in or register to reply here.
Back
Top