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]

[color=darkblue]Sub[/color] Filter_Copy_Uniques_Max_10_Rows()
    
    [color=green]'this macro assumes that your first row of data is a header row.[/color]
    [color=green]'Unique filtered values (max 10 rows copied)[/color]
    
    [color=green]'Variables used by the macro[/color]
    [color=darkblue]Dim[/color] wsDest [color=darkblue]As[/color] Worksheet
    [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] LR [color=darkblue]As[/color] [color=darkblue]Long[/color], NextRow [color=darkblue]As[/color] [color=darkblue]Long[/color], LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=green]' Destination worksheet[/color]
    [color=darkblue]Set[/color] wsDest = Worksheets("Sheet15")
    
    [color=green]' Set the filter range (from E1 to the last used cell in column E)[/color]
    LR = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
    [color=darkblue]Set[/color] rngFilter = ActiveSheet.Range("E1", ActiveSheet.Range("E" & LR))
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    
    [color=green]' Filter column E to show only one of each item (uniques) in column E[/color]
    rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=[color=darkblue]True[/color]
    [color=green]' Set a variable to the Unique values[/color]
    [color=darkblue]Set[/color] rngUniques = Range("E2:E" & LR).SpecialCells(xlCellTypeVisible)
    [color=green]' Clear the filter[/color]
    [color=darkblue]If[/color] rngFilter.Parent.FilterMode [color=darkblue]Then[/color] rngFilter.Parent.ShowAllData
    
    [color=green]' Filter, Copy, and Paste each unique[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] rngUniques
        
        [color=green]'NOTE - this filter is on column E[/color]
        rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
        
        [color=green]' Copy and paste the filtered data to the destination worksheet[/color]
        NextRow = wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
        Rows("2:" & LR).SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("A" & NextRow)
        
        [color=green]'Delete more than 10 pasted rows[/color]
        LastRow = wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
        [color=darkblue]If[/color] LastRow >= NextRow + 10 [color=darkblue]Then[/color] Sheets("Sheet15").Rows(NextRow + 10 & ":" & LastRow).ClearContents
        
    [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]

 

[MSKUMAR]

Thank you Thank you Thank you so much

You are Super super!!!!!!!!!!!!!!!

 

[AlphaFrog]

You're welcome.

 

[dougajo]

I love this code except the actual copy is not copying. It creates the range, opens the new workbook and then selects the range in the workbook which fits the range in the workbook with the data, but nothing copies, nor are the column widths changing. I did not alter the code at all.

After it completed running I tried to manually paste the data in the clipboard but again nothing happened.

Has no one else ran into this trouble?

Oh.. I would add that it does loop through fine and create each workbook and names them OK. Not data shows up in them though.

Dojo

 

[win8282]

Dear AlphaFrog (AKA excel god)

Your code has worked perfectly after a few tweaks!
However, I have a question as to how I could make the VBA code work for filenames over 30 characters (the code bugs out once it filters a filename longer than 30 characters). Or if that is not possible, is there a way to maybe add a sub so that the filename only copies up to the first 30 characters?

Is there any elegant way to go about this?

Thank you so much for your help. You are a lifesaver

 

[AlphaFrog]

how I could make the VBA code work for filenames over 30 characters (the code bugs out once it filters a filename longer than 30 characters). Or if that is not possible, is there a way to maybe add a sub so that the filename only copies up to the first 30 characters?

Perhaps a question like this is better suited for its own new thread. Is a bit off the original topic.

FileName = Left(FileName, 30)

That will truncate a file name to a max of 30 characters.

 

[Johnny Thunder]

Alphafrog,

This thread has crossed the sea of time and is still an awesome masterpiece.

Had a few questions on the code I found on your original post

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 A1 to the last used cell in column A)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("E" & 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
        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 A (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
        
        ' 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, "mmm_dd_yyyy")
'        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
  
  End Sub

My workbook has columns A:E with a header row data starts on row 2.

• Column A is my filter criteria "ID Name"
Example: ABC-000332

•Columns B:E are simply metadata I want brought along with the ID Name.

• Column A (ID Name) has the same name repeated between 5-7 times so when the Unique Value is filtered there are usually 5-7 rows of data

I am getting an error message that says "Filename can not be used to an already existing File" Something like that. I noticed that the VBA is creating 3 new workbooks with the same filtered data?

Not sure if the code I am using is causing an issue or maybe with all the different iterations of your code out there I may have grabbed one that was tweaked?

The folder location where the files are being saved is empty aside from the Source file which has name that is Generic like "Source".

Any help is appreciated. Thanks!

 

[Johnny Thunder]

What I was trying to accomplish is that when the code sees a new ID Name, it filters the name, gives a list 5-7 rows of data and then saves the list with the unique name as the code was setup to do. I think the issue is that my data has the same name repeated multiple times. Maybe tripping up the code.

Note: I duplicated my data to another sheet and removed all duplicates from Column A and then the current code worked fine.

Hopefully I explained my issue thoroughly.

 

[AlphaFrog]

I think the issue is that my data has the same name repeated multiple times. Maybe tripping up the code.

Note: I duplicated my data to another sheet and removed all duplicates from Column A and then the current code worked fine.

The code looks fine. I tested your code with made-up data ind it worked for me. It's suppose to define the unique IDs (col A) and then filter each ID for duplicates, then copy the filtered rows (same IDs) to there own workbook.

Are the duplicate IDs exact duplicate IDs? Can you give some examples?

Are there no filters set before you run the macro?

 

[Johnny Thunder]

The code looks fine. I tested your code with made-up data ind it worked for me. It's suppose to define the unique IDs (col A) and then filter each ID for duplicates, then copy the filtered rows (same IDs) to there own workbook.

Are the duplicate IDs exact duplicate IDs? Can you give some examples?

Are there no filters set before you run the macro?

No prior filters. And yes, there are exact duplicate ID's.

Sample files saved to my dropbox. - https://www.dropbox.com/s/sb2dvhyce8i5nlp/extract1.xlsm?dl=0

I have the macro in their as well and if you fire it you will see what I mean on how it doesn't seem to be removing the first filter and it is trying to save the same unique value multiple times.

Thanks again for your help on this.