VBA:copy rows based on criteria to a new sheet/file.

[lakersbg]

Dear Excel pros,
Unfortunately I don't know much about the VBA language so I'll appreciate it if you could help me on the following macro:
Each month I get two files with data which I have to reconcile (find for each customer account (let's say each unique value in column A) the rows that are missing in one of the two files. So, I want to do a macro which would help me, once I've put the data into one sheet and sorted on Column A, to copy the rows containing each unique value in A (each customer) into a new sheet/file. After that I can easily delete the duplicate rows and see what is missing from one of the files.
I found a macro that more or less suits me, but I need to make it repeat itself for each unique value in Column A (or from a list of values if it will be easier).
Here is the macros that I found, you can modify it to suite my purpose. Big thank you in advance!
Best Regards,
Lakersbg

Sub Extract_Data()
'this macro assumes that your first row of data is a header row.
'will copy a row from one worksheet, to another blank workbook
'IF there is a 0 in column N
'Variables used by the macro
Application.ScreenUpdating = False
Dim FilterCriteria
Dim CurrentFileName As String
Dim NewFileName As String

'Get the current file's name
CurrentFileName = ActiveWorkbook.Name
'Select Range
'(note you can change this to meet your requirements)
Range("A1:AS3000").Select
'Apply Autofilter
Selection.AutoFilter
FilterCriteria = Range("Sheet2!A1").Value
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
Selection.AutoFilter field:=1, Criteria1:=FilterCriteria
'Select the visible cells (the filtered data)
Selection.SpecialCells(xlCellTypeVisible).Select
'Copy the cells
Selection.Copy
'Open a new file
Workbooks.Add Template:="Workbook"
'Get this file's name
NewFileName = ActiveWorkbook.Name
'Make sure you are in cell A1
Range("A1").Select
'Paste the copied cells
ActiveSheet.Paste
'Clear the clipboard contents
Application.CutCopyMode = False
'Go back to the original file
Workbooks(CurrentFileName).Activate
'Clear the autofilter
Selection.AutoFilter field:=1
'Take the Autofilter off
Selection.AutoFilter
'Go to A1
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[tcfreer]

Update

Managed to find a way round it - it was a small error and over site on my side.

Code as I am currently using

Sub Extract_All_Data_To_New_Workbook()
    
    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own workbook
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    Dim shSource As Worksheet
    
    Set shSource = Sheets("POs")    'Source worksheet
    
    ' Set the filter range (from E1 to the last used cell in column E)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column E to show only one of each item (uniques) in column E
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = shSource.Range("Z2", shSource.Range("Z" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        shSource.ShowAllData
        'shSource.Cells.AutoFilter
        
    End With
    
    ' Filter, Copy, and Paste each unique to its own new workbook
    For Each cell In rngUniques
    
        ' Create a new workbook for each unique value
        Set wbDest = Workbooks.Add(xlWBATWorksheet)
                
        'NOTE - this filter is on column E (field:=5), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=5, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to its new workbook
        rngFilter.EntireRow.Copy
        With wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           'Paste column widths
            .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
        End With
        Application.CutCopyMode = True
        
        ' Name the destination sheet
        wbDest.Sheets(1).Name = cell.Value
        
        'Save the destination workbook and close
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "ddmmyy")
            
        'Save the workbook path and name in adjacent cell 'Question 2
        cell.Offset(, 1).Value = wbDest.FullName
        cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(, 2), _
            Address:=wbDest.FullName, TextToDisplay:=wbDest.Name
        
        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
  
End Sub

 

[tcfreer]

AlphaFrog

Just a Quick Question

Based on the above - is possible to add in a if statement of sorts, so that if there is the need to select just 1 name from a list and run this out of normal time frames is it hard to add in?

If not were and what should I add in?

I have a cell with a drop down list held in there of the list of names I am using.

Cell reference for that is Worksheet("Summary Sheet").Cell("B8")

Not sure how hard it is or if its possible?

 

[AlphaFrog]

If you're asking to do a one-off filter, it's probably easier to just have a separate macro.

Try this. I didn't test it.

[COLOR=darkblue]Sub[/COLOR] Filter_Data_To_New_Workbook()
    
    [COLOR=green]'this macro assumes that your first row of data is a header row.[/COLOR]
    [COLOR=green]'will copy filtered rows from one worksheet, to another blank workbook[/COLOR]
    
    [COLOR=green]'Variables used by the macro[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] wbDest [COLOR=darkblue]As[/COLOR] Workbook
    [COLOR=darkblue]Dim[/COLOR] rngFilter [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] shSource [COLOR=darkblue]As[/COLOR] Worksheet
    
[B]    [COLOR=darkblue]Set[/COLOR] cell = Worksheet("Summary Sheet").Range("B8") [COLOR=green]'Filter value[/COLOR][/B]
    
    [COLOR=darkblue]Set[/COLOR] shSource = Sheets("POs")    [COLOR=green]'Source worksheet[/COLOR]
    [COLOR=green]' Set the filter range (from E1 to the last used cell in column E)[/COLOR]
    [COLOR=green]'(Note: you can change this to meet your requirements)[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
    
    [COLOR=green]' Create a new workbook for each unique value[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wbDest = Workbooks.Add(xlWBATWorksheet)
            
    [COLOR=green]'NOTE - this filter is on column E (field:=5), to change[/COLOR]
    [COLOR=green]'to a different column you need to change the field number[/COLOR]
    rngFilter.AutoFilter Field:=5, Criteria1:=cell.Value
    
    [COLOR=green]' Copy and paste the filtered data to its new workbook[/COLOR]
    rngFilter.EntireRow.Copy
    [COLOR=darkblue]With[/COLOR] wbDest.Sheets(1).Range("A1")
        .PasteSpecial xlPasteColumnWidths           [COLOR=green]'Paste column widths[/COLOR]
        .PasteSpecial xlPasteValuesAndNumberFormats [COLOR=green]'Paste values[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    Application.CutCopyMode = [COLOR=darkblue]True[/COLOR]
    
    [COLOR=green]' Name the destination sheet[/COLOR]
    wbDest.Sheets(1).Name = cell.Value
    
    [COLOR=green]'Save the destination workbook and close[/COLOR]
    wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
        cell.Value & " " & Format(Date, "ddmmyy")
        
    [COLOR=green]'Save the workbook path and name in adjacent cell 'Question 2[/COLOR]
    cell.Offset(, 1).Value = wbDest.FullName
    cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(, 2), _
        Address:=wbDest.FullName, TextToDisplay:=wbDest.Name
    
    wbDest.Close [COLOR=darkblue]False[/COLOR] [COLOR=green]'Close the new workbook[/COLOR]
            
    rngFilter.Parent.AutoFilterMode = [COLOR=darkblue]False[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
  
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

 

[tcfreer]

Maybe - the reason I was looking at a IF statement is because there has now arisen the possibility that this file instead of being used on a set day each week, would need to be used on a ad hoc basis.

I was hoping to be able to use a drop down on one sheet, with if statement in the vba so that if a value was selected here then just filter to that - if its blank, then run as normal

I'll try the update code.

Again thanks for taking your time out to do this - it really is a great piece of work

 

[tcfreer]

Ok update from me - Couldn't quite get that amended code to work as intended so currently just running the standard code.

I have been asked to cut the data down that we send

The data I want to send is stored in columns A to J

What line do I need to edit to select just these columns and all the rows under it

The current one I have running is

Sub Extract_All_Data_To_New_Workbook()
    
    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own workbook
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    Dim shSource As Worksheet
    
    Set shSource = Sheets("POs")    'Source worksheet
    
    ' Set the filter range (from E1 to the last used cell in column E)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column E to show only one of each item (uniques) in column E
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = shSource.Range("Z2", shSource.Range("Z" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        shSource.ShowAllData
        'shSource.Cells.AutoFilter
        
    End With
    
    ' Filter, Copy, and Paste each unique to its own new workbook
    For Each cell In rngUniques
    
        ' Create a new workbook for each unique value
        Set wbDest = Workbooks.Add(xlWBATWorksheet)
                
        'NOTE - this filter is on column E (field:=5), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=5, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to its new workbook
        rngFilter.EntireRow.Copy
        With wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           'Paste column widths
            .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
        End With
        Application.CutCopyMode = True
        
        ' Name the destination sheet
        wbDest.Sheets(1).Name = cell.Value
        
        'Save the destination workbook and close
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "ddmmyy")
            
        'Save the workbook path and name in adjacent cell 'Question 2
        cell.Offset(, 1).Value = wbDest.FullName
        cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(, 2), _
            Address:=wbDest.FullName, TextToDisplay:=wbDest.Name
        
        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
  MsgBox "Completed"
End Sub

Many thanks for the help in this

 

[AlphaFrog]

The data I want to send is stored in columns A to J

What line do I need to edit to select just these columns and all the rows under it

        [COLOR=#008000]' Copy and paste the filtered data to its new workbook[/COLOR]
        rngFilter.EntireRow[B].Columns("A:J")[/B].Copy

 

[tcfreer]

Perfect.

Thank you so much for this

 

[tcfreer]

A further update from me

Sub Extract_All_Data_To_New_Workbook()
    
    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own workbook
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    Dim shSource As Worksheet
    
    Set shSource = ThisWorkbook.Sheets("POs")    'Source worksheet
    
    ' Set the filter range (from E1 to the last used cell in column E)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column E to show only one of each item (uniques) in column E
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = shSource.Range("Z2", shSource.Range("z" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        shSource.ShowAllData
        'shSource.Cells.AutoFilter
        
    End With
    
    ' Filter, Copy, and Paste each unique to its own new workbook
    For Each cell In rngUniques
    
        ' Create a new workbook for each unique value
        Set wbDest = Workbooks.Add(xlWBATWorksheet)
                
        'NOTE - this filter is on column E (field:=5), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=5, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to its new workbook
        rngFilter.EntireRow.Columns("A:J").Copy
        With wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           'Paste column widths
            .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
        End With
        Application.CutCopyMode = True
        
        ' Name the destination sheet
        wbDest.Sheets(1).Name = cell.Value
        
        'Save the destination workbook and close
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "ddmmyy")
            
        'Save the workbook path and name in adjacent cell 'Question 2
        cell.Offset(, 1).Value = wbDest.FullName
        cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(, 2), _
            Address:=wbDest.FullName, TextToDisplay:=wbDest.Name
        
        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    Sheets("POs").ShowAllData
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
  MsgBox "Completed"
End Sub

My issue is that the top and bottom of the filter aren't being copied properly resulting in blank sheets being out put.

Is there something I am missing that's simple?

 

[AlphaFrog]

Change the the Field:=5 to a 1.

Originally, the code was filtering a range from column A to E and the Autofilter was to filter on column E (Field 5).
Now you are filtering only one column (Z). So Field:=1 is the first column within the filter range.

        [COLOR=green]'NOTE - this filter is on column E (field:=5), to change[/COLOR]
        [COLOR=green]'to a different column you need to change the field number[/COLOR]
        rngFilter.AutoFilter Field:=[COLOR=#ff0000]1[/COLOR], Criteria1:=cell.Value

 

[tcfreer]

Hi Alpha

Sorry, still not working as intended?

What happens when I run the code is that while all the other unique values extract fine, the top and bottom ones of the list don't populate on there sheets - and there is rows of data when you manually filter on them.

Now I might need to clarify when I say top I mean row 2 - the first line of data, and bottom being the last line of data.

So when the code runs, it filters on the first unique name, and shows a blank sheet - yet when I do the same I get (In the case of the first one) 1 line of data - after the headers.

The headers are constant in row 1, and the actual data starts in row 2