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

 

[SFPCFS]

Np Apologies for that.

Done as requested many thanks for the assistance

 

[coshtor]

I have been beating my head against the wall on this one. The code above works GREAT to copy it to a new worksheet if i want entire rows to a new sheet. Where Im having problems Is this. I load data into sheet 1 from a large number of different access files and I need to break it out to sheets based on zip code. The reason I need to copy only columns A through K is I have some stuff out to the right of K that I don't want copied over. The sheets at the bottom need to be named based on zip code. I have taken care of sheet creation with my function, but I cant figure out how to get the data into that sheet. Any help would be greatly appreciated.

Sub Extract_All_Data_To_New_Worksheets()
    Dim wsDest As String
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    'set rngfilter to all used cells in the K colum
    Set rngFilter = Range("K1", Range("K" & Rows.count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        'filter Colum K to only show unique values
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        'set the var to the uniques, excluding row 1, as thats the header.
        Set rngUniques = Range("K2", Range("K" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        'clear the filter
        ActiveSheet.ShowAllData
    End With
    
    ' Filter, Copy, and Paste each unique to its own new worksheet
    For Each cell In rngUniques
    
        If cell.value <> "" Then
    
            'call function CreateSheetIf to create the sheet if non-existant
            CreateSheetIf (cell.value)
                    
            'Applys filter on Column K to only show the unique values obtained earlier.
            rngFilter.AutoFilter Field:=11, Criteria1:=cell.value
            
            ' Copy and paste the filtered data to its new worksheet
            rngFilter.Range("A2", "K" & Range("K" & Rows.count).End(xlUp).Row).Copy
            With Sheets(cell.value).Range(Range("A" & Rows.count).End(xlUp))
                .PasteSpecial xlPasteColumnWidths           'Paste column widths
                .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
            End With
            Application.CutCopyMode = True
        
        End If
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub

Function CreateSheetIf(strSheetName As String) As Boolean
    Dim wsTest As Worksheet
    Dim wscode As String
    CreateSheetIf = False
     
    Set wsTest = Nothing
    On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
    On Error GoTo 0
     
    If wsTest Is Nothing Then
        CreateSheetIf = True
        Worksheets.Add(After:=Sheets(Sheets.count)).Name = strSheetName
    End If
     
End Function

 

[AlphaFrog]

rngFilter.Range("A2", "K" & Range("K" & Rows.count).End(xlUp).Row).Copy

The Range object should have a sheet qualifier or it will default to the active sheet which may be a newly added sheet.

Try this...
rngFilter.Parent.Range("A2", rngFilter.Parent.Range("K" & Rows.count).End(xlUp)).Copy


This is another approach
rngFilter.EntireRow.Columns("A:K").Copy

 

[coshtor]

Thank you for that. The other problem I'm having is on this line

With Sheets(cell.value).Range(Range("A" & Rows.count).End(xlUp))

Run-time Error '9': Subscript out of range.

 

[dylanrose]

Hi and welcome to the forum. Also, well done on first searching for a solution.

This will save each unique-value's row to a new workbook and save the workbook to the same location as the the source macro workbook. The file names will be the cell value and the current date. Change the red date format 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=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("A1", Range("A" & 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("A2", Range("A" & 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 A (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]
        
        [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, [COLOR=#ff0000]"mmm_dd_yyyy"[/COLOR])
[COLOR=green]'        wbDest.Close False '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]

Hi AlphaFrog,

I would like to ask, how would this code be able to export it into a semi-colon delimited csv file? What should be changed?

Thanks,
Dylan

 

[AlphaFrog]

Here's a simple trick. Change your system setting.
Save Excel File with any Special character Delimiter

Then add this to save it as a CSV file format

        [COLOR=green]'Save the destination workbook as Semicolon delimited text file and close[/COLOR]
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, "mmm_dd_yyyy")[COLOR=#FF0000], FileFormat:=xlCSV[/COLOR]

 

[MSKUMAR]

Hi Alpha,

You are really brilliant!!!!!!!!

This thread is very helpful and sorry to raise question again on same topic.

I have code something like below which i have to manually give names in the criteria. After looking your codes, I applied and It is pasting into new sheets but i need all filtered data should be in single sheet but limited to first 10 Rows for each criteria.

some times, Criteria may contain less than 10 rows and need to copy what ever filtered.

Hope, I make you clear on my question.

Thanks in Advance

MSK

Selection.AutoFilter Field:=5, Criteria1:="A"
Set Rng = Cells.SpecialCells(xlCellTypeVisible)
Rng.Copy Destination:=Sheets("Sheet15").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

Selection.AutoFilter Field:=5, Criteria1:="A"
LR = Cells(Rows.Count, 1).End(xlUp).Row
Rows("2:" & LR).Copy Destination:=Sheets("Sheet15").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

 

[AlphaFrog]

Hardly brilliant, but thank you.

You want to copy a maximum of 10 filtered rows; is that correct?

LR = Cells(Rows.Count, 1).End(xlUp).Row
NextRow = Sheets("Sheet15").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Rows("1:" & LR).AutoFilter Field:=5, Criteria1:="A"
Rows("2:" & LR).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Sheet15").Range("A" & NextRow)
[color=green]'Delete more than 10 pasted rows[/color]
LR = Sheets("Sheet15").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
[color=darkblue]If[/color] LR >= NextRow + 10 [color=darkblue]Then[/color] Sheets("Sheet15").Rows(NextRow + 10 & ":" & LR).Clear

 

[MSKUMAR]

Hi Alpha,

After seeing your posts, Everybody will appreciate for sure. Your code is helping us that much.

Thanks for your reply.

I was searching for filter related code since 3 Days. By luck, I found your thread.

Yes you are right, maximum of 10 or it can be in any percentage(Manually can change).
Regards
MSK

 

[MSKUMAR]

Hi Alpha,

In That code, it is copying only Criteria A, It has to pull out All unique Filtered records(A-10,B-10,C-10 etc.,) maximum of 10 or any percentage(manually change). I am trying to change the code which given in initial threads.

Thanks
MSK