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]

Perhaps you can upload an example file (remove any sensitive info.) to a file share site and post the link here. I'll take a look at it.

 

[tcfreer]

Any suggestions on upload areas?

Happy to upload it for you

 

[tcfreer]

Ok got one

Alpha link as requested

https://1drv.ms/x/s!AmndacLQ7od7hUcAYrXlZZRbhoQs

 

[AlphaFrog]

The link didn't work. Try DropBox.com

 

[tcfreer]

https://www.dropbox.com/s/31xts3w7w71hc6e/PO Supplier Master.xlsm?dl=0

try that

 

[AlphaFrog]

Give this a try.

[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] shSource [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] v [color=darkblue]As[/color] [color=darkblue]Variant[/color], i [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]Set[/color] shSource = ThisWorkbook.Sheets("POs")    [color=green]'Source worksheet[/color]
    
    Application.ScreenUpdating = [color=darkblue]False[/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]
    v = shSource.Range("E2", shSource.Range("E" & Rows.Count).End(xlUp))
    [color=darkblue]For[/color] i = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](v, 1)
        v(i, 1) = Left(v(i, 1), 25)
    [color=darkblue]Next[/color]
    Range("Z2").Resize(UBound(v, 1)).Value = v
    [color=darkblue]Set[/color] rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
        
    [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 = shSource.Range("Z2", shSource.Range("Z" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    
    [color=green]' Clear the filter[/color]
    [color=darkblue]If[/color] shSource.FilterMode [color=darkblue]Then[/color] shSource.ShowAllData
    
    [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 E (field:=5), 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.Columns("A:J").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]
        
    [color=darkblue]Next[/color] cell
    
    [color=darkblue]If[/color] shSource.FilterMode [color=darkblue]Then[/color] shSource.ShowAllData
    shSource.AutoFilterMode = [color=darkblue]False[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
    MsgBox "Completed"
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[tcfreer]

Hi

Tried it - all sheets come back with just the header row now.

Its like it doesn't count the rows or do a xLDown

It takes the header of the sheet and copies that fine - and labels it with the name of what it should it contain the rows of data for - it just doesn't copy them all over

 

[AlphaFrog]

It works for me on your example workbook. Are you testing on the same workbook?

 

[tcfreer]

Cracked it

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
    Dim v As Variant, i As Long
    
    Set shSource = ThisWorkbook.Sheets("POs")    'Source worksheet
    
    Application.ScreenUpdating = False
    
    ' Set the filter range (from E1 to the last used cell in column E)
    '(Note: you can change this to meet your requirements)
    v = shSource.Range("Z2", shSource.Range("Z" & Rows.Count).End(xlUp))
    For i = 1 To UBound(v, 1)
        v(i, 1) = Left(v(i, 1), 25)
    Next
    Range("Z2").Resize(UBound(v, 1)).Value = v
    Set rngFilter = shSource.Range("Z1", shSource.Range("Z" & Rows.Count).End(xlUp))
        
    ' Filter column E to show only one of each item (uniques) in column E
    rngFilter.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
    If shSource.FilterMode Then shSource.ShowAllData
    
    ' 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:=26, 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
    
    If shSource.FilterMode Then shSource.ShowAllData
    shSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Completed"
    
End Sub

SH Source range was the issue looking at E now Z as well.

Switched it and it works perfectly now.

Thanks for the guidance Alfa

 

[roy00a4]

Hi AlphaFrog,

I must say, its amazing to see your work. This thread is immensly informative, thanks to you. I am fairly new to VBA. I am able to get the codes that you have upload from the very begining of the thread more than 3 years back.

I have two sheets, "Dump Filter" and "Master". In "Dump Filter" colA to colBT is occupied with data of sales of a ecommerce site. In "Master" colA to colBV is occupied with the filtered data from "Dump Filter". I have tried multiple codes to Copy colB to colBT from "Dump Filter" based on a criteria on colA which is "Not In Master", and paste the copied rows in "Master" in colD to colBV below the last used row.

I hope i was able to explain the situation. I have used the code posted in #166 thread. But nothing happens. If you could please help me with the solution it would be of great help.

Thank you so much for all your time and help. Thank you.

Please help !!