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

 

[AlphaFrog]

Change this...

Set rngFilter = Range("A1", Range("[COLOR=#ff0000]A[/COLOR]" & Rows.Count).End(xlUp))

Remember to delete any previously saved files from the destination folder.

 

[Johnny Thunder]

Change this...

Set rngFilter = Range("A1", Range("[COLOR=#ff0000]A[/COLOR]" & Rows.Count).End(xlUp))

Remember to delete any previously saved files from the destination folder.

Worked like a charm!

Thanks again.

2 last questions, can I modify the code to save the files as a PDF? - Saw a few threads about PDF's not working well because of the lag to create the files.

And how can I edit the code to not include the date stamp in the file name.

thanks again!

 

[AlphaFrog]

2 last questions, can I modify the code to save the files as a PDF? - Saw a few threads about PDF's not working well because of the lag to create the files.

And how can I edit the code to not include the date stamp in the file name.

thanks again!

You're welcome.

Change this...

        [COLOR=green]'Save the destination workbook and close[/COLOR]
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "mmm_dd_yyyy")
[COLOR=green]'        wbDest.Close False 'Close the new workbook[/COLOR]

To this...

        [COLOR=green]'Save the destination as PDF workbook and close[/COLOR]
        [COLOR=green]'For Excel 2007 and later[/COLOR]
        wbDest.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            FileName:=ThisWorkbook.Path & Application.PathSeparator & cell.Value & ".PDF", _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=[COLOR=darkblue]False[/COLOR]
            
        wbDest.Close [COLOR=darkblue]False[/COLOR] [COLOR=green]'Close the new workbook[/COLOR]

 

[Johnny Thunder]

Your the Man!!!!!

Worked perfectly.Tried a code previously and it would always time out after about 60pdf's this worked perfectly for all 1400 files I needed. Thank you so much for the prompt repsoneses!

You're welcome.

Change this...

        [COLOR=green]'Save the destination workbook and close[/COLOR]
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "mmm_dd_yyyy")
[COLOR=green]'        wbDest.Close False 'Close the new workbook[/COLOR]

To this...

        [COLOR=green]'Save the destination as PDF workbook and close[/COLOR]
        [COLOR=green]'For Excel 2007 and later[/COLOR]
        wbDest.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            FileName:=ThisWorkbook.Path & Application.PathSeparator & cell.Value & ".PDF", _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=[COLOR=darkblue]False[/COLOR]
            
        wbDest.Close [COLOR=darkblue]False[/COLOR] [COLOR=green]'Close the new workbook[/COLOR]

 

[clane1]

Alpha, I've read so many of your posts and you aretruly a great help to so many of us. With that, I do have a question.

I have a file with a couple thousand unique rows of data. Many people are assigned to multiple fields of data for a total of only 61 people for the two thousand names. I have the names in Column Q, header in row 1. I want to sort on column Q and copy all rows of data to a new file in a location on a network drive (I'll fill in name on my side) and save the file name based on the persons name in column Q with a current date. Thank you so much!

 

[AlphaFrog]

Alpha, I've read so many of your posts and you aretruly a great help to so many of us. With that, I do have a question.

I have a file with a couple thousand unique rows of data. Many people are assigned to multiple fields of data for a total of only 61 people for the two thousand names. I have the names in Column Q, header in row 1. I want to sort on column Q and copy all rows of data to a new file in a location on a network drive (I'll fill in name on my side) and save the file name based on the persons name in column Q with a current date. Thank you so much!

Thank you for the feedback. It's always appreciated.

I'm not sure what your "question" is, but did you try editing any versions of the macros in this thread. Your description is basically the same as several of the previous macros. Post #21 is similar to what you describe except the filter column is A.

 

[clane1]

I am having trouble with the closing of the files and saving as name in cell value. It is opening each new workbook but not closing them leaving me with 60 open worksheets on my desktop. It is also saving my original master file "Test" as the last filtered value name. This is saving the new workbook in my fodler with the right name based on a cell value. I seemt o be changing the wrong fields to filter from column A to column Q...can you tell which all fields in the text below need to be changed? I am tried everything I can think of and cannot get it to work.

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
    
    ' Set the filter range (from Q1 to the last used cell in column Q)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    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 Q (field:=17), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=1, 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
        Dim FName           As String
        Dim FPath           As String
     
    FPath = "J:path"
    FName = Sheets("Sheet1").Range("Q2").Text
    ThisWorkbook.SaveAs Filename:=FPath & "\" & FName & ".xls"

'        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub

 

[AlphaFrog]

Change the path to suit.

[color=darkblue]Sub[/color] Extract_All_Data_To_New_Workbook()
    
    [color=green]'this macro assumes that your first row of data is a header row.[/color]
    [color=green]'will copy all filtered rows from one worksheet, to another blank workbook[/color]
    [color=green]'each unique filtered value will be copied to it's own 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, rngUniques [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] strPath [color=darkblue]As[/color] [color=darkblue]String[/color]
     
    strPath = [COLOR=#ff0000]"C:\Test"[/COLOR]
    
    [color=green]' Set the filter range (from Q1 to the last used cell in column Q)[/color]
    [color=green]'(Note: you can change this to meet your requirements)[/color]
    [color=darkblue]Set[/color] rngFilter = Range("Q1", Range("Q" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    
    [color=darkblue]With[/color] rngFilter
        
        [color=green]' Filter column Q to show only one of each item (uniques) in column A[/color]
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=[color=darkblue]True[/color]
        
        [color=green]' Set a variable to the Unique values[/color]
        [color=darkblue]Set[/color] rngUniques = Range("Q2", Range("Q" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        [color=green]' Clear the filter[/color]
        ActiveSheet.ShowAllData
        
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=green]' Filter, Copy, and Paste each unique to its own new workbook[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] rngUniques
    
        [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 Q (field:=1), to change[/color]
        [color=green]'to a different column you need to change the field number[/color]
        rngFilter.AutoFilter Field:=1, 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]
        
        wbDest.SaveAs Filename:=strPath & "\" & cell.Value & ".xls"
        wbDest.Close [color=darkblue]False[/color] [color=green]'Close the new workbook[/color]
        
    [color=darkblue]Next[/color] cell
    
    rngFilter.Parent.AutoFilterMode = [color=darkblue]False[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[DunnRight]

Hi Alpha. I have read all 8 pages of this post and have tried three versions of this, but none seem to work for me. I either get a "Type Mismatch" error or the "Showalldata method of worksheet class failed". How can I post a sample workbook so you can see my data and help me figure this out?

 

[DunnRight]

Here is the code that I am currently trying to use. It gives me an error when it gets to the showalldata part. What am I doing wrong?

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 strPath As String
     
    strPath = "B:\"
    
    ' Set the filter range (from B1 to the last used cell in column B)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("B1", Range("B" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column B to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    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 B (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=1, 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
        
        wbDest.SaveAs Filename:=strPath & cell.Value & ".xls"
        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub