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

 

[Slomaro2000]

This code is great! Pretty much what I was looking for.

I have a question though. I have a specific folder that has multiple folders in it that are named the same thing that the Tabs are. Can you modify this to save them in that folder based on the tab name?

So if the tab name is DOGS you are saving the file as DOGS MMM_DD_YYYY in the current workbook file path. Can you send that to a Main folder that has sub folders of DOGS , CATS and separate based on the tab name? So the folder DOGS only has the tabs Dogs and so on?

And if there is not a folder could this create one?

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("C1", Range("C" & 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("C2", Range("C" & 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 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

 

[AlphaFrog]

Change the Main Folder path to suit.

        [COLOR=green]'Save the destination workbook and close[/COLOR]
        strPath = [COLOR=#ff0000]"C:\Main Folder\"[/COLOR] & cell.Value & "\"
        [COLOR=darkblue]If[/COLOR] Dir(strPath, vbDirectory) = "" [COLOR=darkblue]Then[/COLOR] MkDir strPath
        wbDest.SaveAs strPath & cell.Value & " " & Format(Date, "mmm_dd_yyyy")

 

[Slomaro2000]

Thanks AlphFrog! Think thats just what I needed.

 

[VBABEGINER]

I think I just woke up from my unstable mind....

What a brain you have AlphaFrog..ray:

This code is awesome...this what I exactly require.

Thank a lot...for the post also..

VBABEGINER, India.

 

[VBABEGINER]

Dear AlhpaFrog,


Could you please help in alter this code-
Requirement--
Instead of in single workbook, I require to save the data on every new workbook and save every workbook by the name contains in Col B2...


Could you please please share me the code..

I think I just woke up from my unstable mind....

What a brain you have AlphaFrog..ray:

This code is awesome...this what I exactly require.

Thank a lot...for the post also..

VBABEGINER, India.

 

[AlphaFrog]

Could you please help in alter this code-
Requirement--
Instead of in single workbook, I require to save the data on every new workbook and save every workbook by the name contains in Col B2...

This thread is 5 years old with 95 posts and dozens of versions of the macro. You'll have to be much more specific.

 

[VBABEGINER]

This thread is 5 years old with 95 posts and dozens of versions of the macro. You'll have to be much more specific.

Hi AlphaFrog,

I am talking about this code..sorry...this brilliant code..

Sub Extract_All_Data()


'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 sheet

'Variables used by the macro
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range, counter As Integer

' 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("B1", Range("B" & 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("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

' Clear the filter
ActiveSheet.ShowAllData

End With

' Create a new workbook with a sheet for each unique value
Application.SheetsInNewWorkbook = rngUniques.Count
Set wbDest = Workbooks.Add
Application.SheetsInNewWorkbook = 3


' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
For Each cell In rngUniques

counter = counter + 1

'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 it's unique sheet
rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
' Name the destination sheet
wbDest.Sheets(counter).Name = cell.Value
wbDest.Sheets(counter).Cells.Columns.AutoFit

Next cell

MsgBox "Complete"

rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True

End Sub

Here, instead of multiple worksheet, I require to paste the data in every every new workbook and workbook should get save by Col B2 name.

As I am using, column B..

Set rngFilter = Range("B1", Range("B" & Rows.Count).End(xlUp))

Please please, assist me sir..

 

[AlphaFrog]

It saves to the same folder as the workbook that has the code.

[COLOR=darkblue]Sub[/COLOR] Extract_Filtered_Data_To_Workbooks()
    
    [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 sheet[/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, counter [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
    
    [COLOR=green]' Set the filter range (from A1 to the last used cell in column A)[/COLOR]
    [COLOR=green]'(Note: you can change this to meet your requirements)[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rngFilter = Range("B1", Range("B" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] rngFilter
        
        [COLOR=green]' Filter column A 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("B2", Range("B" & 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 sheet in the new workbook[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngUniques
        
        counter = counter + 1
        
        [COLOR=green]'filter is on column B[/COLOR]
        rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
        
        [COLOR=green]' Copy and paste the filtered data to a new worbook[/COLOR]
        [COLOR=darkblue]With[/COLOR] Workbooks.Add(xlWBATWorksheet)
            rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=ActiveSheet.Range("A1")
            Columns.AutoFit
            [COLOR=green]' Save\close the new workbook[/COLOR]
            ActiveWorkbook.SaveAs fileName:=ThisWorkbook.Path & "\" & cell.Value, FileFormat:=51
            ActiveWorkbook.Close
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        
    [COLOR=darkblue]Next[/COLOR] cell
    
    MsgBox "Complete"
    
    rngFilter.Parent.AutoFilterMode = [COLOR=darkblue]False[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

 

[VBABEGINER]

Hi,

How is that possible to you to make such great code...!!!......that's ok. Great Alpha Frog. Genius mind.

I Just wanted you to point that, there are some file saves as unrecognized file...not in saves as excel. Can you please tell or correct me in code...

 

[VBABEGINER]

Ok, that is beacause of File format 51?