Advanced Filter VBA

[misme21]

I currently have a filter in A3. I have a code that is to select a name in the list. I need to select all names in the list individually and run a code to move them to another sheet which is fine. Right now I have to add each name of someone or delete their name if they are in or not in the filter otherwise I don't get their information. I would really like for it to automatically select each person and run my copy VBA I have and then go to the next person in the list until it gets to the end. Any ideas on how to achieve this.

Right now I am using something like this:


If (Selection.AutoFilter(Field:=1, Criteria1:="WASIK, MARY")) = (Selection.AutoFilter(Field:=1, Criteria1:="WASIK, MARY")) Then
Application.Run "copyto"
Else: Selection.AutoFilter Field:=1, Criteria1:="WEINSTEIN, MITCH J"
End If
If (Selection.AutoFilter(Field:=1, Criteria1:="WEINSTEIN, MITCH J")) = (Selection.AutoFilter(Field:=1, Criteria1:="WEINSTEIN, MITCH J")) Then
Application.Run "copyto"
End If


Would really like to make it more automated so that I don't have to add or delete people.

Thanks.

 

[misme21]

Ok this is not working like I want. I need it to select the next name in the list and after I do that I have a macro that I run to copy the information and apply more formats and at the end of that macro it is set to save close and email and go back to the main page to continue to the next person.

 

[Norie]

I've no idea what you want to do exactly.

The code I posted simply splits the data out by name with a worksheet for the data for each name.

It's basically an example of how to do that with Advanced Filter.

If you already have code to do what you want just get a unique list of the names and loop through it.

 

[misme21]

I guess what I am looking for is for it to select the first name in the above spreadsheet. after it does that it goes through another macro (parts of it are below. After the other macro runs (copying the filtered data from the first page to a new workbook and applying more formatting) it saves the new file, emails it out and then closes and returns to the original spreadsheet. From there I want it to select the next name in the list. My problem is as I showed my sheet before I have to keep it as it is due to formatting so not sure if a unique record works for this.

Selection.AutoFilter Field:=1, Criteria1:="BERZON, DAVE"
Cells.Select
Selection.Copy
Sheets("Clean").Select
Workbooks.Add
Cells.Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1:J1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With

MORE FORMATTING AND THEN

Range("B2:L2").Select
Dim WSName As String, CName As String, Directory As String, SaveName As String
WSName = Range("I3").Select
CName = "I3"
Directory = "G:\Accounting\_GL\MSchwartz\J.P. Morgan Chase\"
SaveName = Range(CName).Text
ActiveWorkbook.SaveAs Filename:=Directory & SaveName & ".xlsx"
Application.Run "EMail"
Range("B2:L2").Select
ActiveWorkbook.Close SaveChanges:=True
Exit Sub
errorsub:
Beep
MsgBox "Changes not saved!", vbExclamation, Title:=SaveName & ".xlsx"
End Sub

 

[Norie]

The code I posted can be adapted to create new workbooks if that's what's needed.

Here's another example which will copy the data to the new workbooks.

It basically does what you just outlined apart from the formatting and emailing which can easily be added.

Option Explicit

Sub DistributeRowsToNewWBS()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim strNewWBName As String
Dim LastRow As Long
    
    Set wsData = Worksheets("Master") ' worksheet data is in, change to suit
    
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    wsData.Range("A3:A" & LastRow).AdvancedFilter action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    
    While rngCrit.Value <> ""
    
        Set wsNew = Worksheets.Add
        
        strNewWBName = rngCrit & "-" & Format(Date, "ddmmmyyyy")
        
        wsData.Rows("3:" & LastRow).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        
        wsNew.Name = rngCrit
        
        wsNew.Copy
        
        Set wbNew = ActiveWorkbook
        
        wbNew.SaveAs ThisWorkbook.Path & "\" & strNewWBName
        
        ' optional - uncomment to close new workbooks
        
        'wbNew.Close SaveChanges:=True
        
        Application.DisplayAlerts = False
        
        wsNew.Delete
        
        rngCrit.EntireRow.Delete
        
        Set rngCrit = wsCrit.Range("A2")
        
    Wend
    
    wsCrit.Delete
    
    Application.DisplayAlerts = True
    
End Sub

 

[misme21]

Ok the only thing I need is to make sure my top two rows are also included on the copy over. I have been trying to get this to work all morning and can't figure it out. Other than my top 2 rows missing I think this will be perfect. Suggestions????

 

[Norie]

Change the destination for the results of the filter:

This is where the code tells the filter where the destination is:

CopyToRange:=wsNew.Range("A1")

So you'll want to change Range("A1") appropriately.

To copy the first 2 rows:

wsData.Rows("1:2").Copy wsNew.Range("A1")

This would go after the data has been copied, if you do it before that the filter might not work properly.

    ' copy filtered data to new sheet
      wsData.Rows("3:" & LastRow).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        
    ' copy rows 1 & 2 from data sheet to new sheet
      wsData.Rows("1:2").Copy wsNew.Range("A1")
    
      ' name the new worksheet.
      wsNew.Name = rngCrit
 
        ' create new workbook from new worksheet
      wsNew.Copy

 

[misme21]

You are the best. I had a few more alterations to make and it works perfectly. I sooooo appreciate your help (sorry I'm new to the VBA codes).