VBA:copy rows based on criteria to a new sheet/file.

L

lakersbg

New Member
Joined
Nov 11, 2010
Messages
20
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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
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, all used columns
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, _
                    Cells.Find("*", [A1], Searchorder:=xlByColumns, Searchdirection:=xlPrevious).Column)
    
    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
    
    ' 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.SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = cell.Value
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Dear Alphafrog, thanks a lot! I really appreciate what you've done for me! However, I get two errors, the first one was about the filter but I overcame it using this script:
on error resume next
activesheet.showalldata
on error goto 0

The second error which I have not yet solved is "can't create another sheet with the same name". Didn't you get the same error when you ran the macro?
Thank you in advance for the help!
Best Regards,
Lakersbg
 
Upvote 0
I don't have your data so I can't duplicate the sheet names. There is something in your data values where two sheet names will be the same for some reason.

Change this line ...
Code: 
wbDest.Sheets(counter).Name = cell.Value

To this...
Code: 
wbDest.Sheets(counter).Name = Counter & " " & cell.Value

That will insure no two sheets have the same name. Or you could just comment out that line to not rename the sheets.
 
Upvote 0
Thanks for the help! However, there are more glitches to be sorted out. When I run the macro, it creates not a single sheet for each account, but multiple sheets according to the number of occurrences, so if an account is present 10 times, it creates 10 sheets with this account. When I ran the macro using my data I got the following error: run-time error 1004. Number must be between 1 & 255. The script line causing the error is:
Application.SheetsInNewWorkbook = rngUniques.Count
Here is a link if you want to download a sample of my data:
http://tranz.it/load.php?id=t9I5kkMp8uwDfT2X671795
The site is in Bulgarian, but just fill in the security pass and click on the download link.

I will greatly appreciate it if you can help me on this final "obstacle" :)
Best Regards,
Lakersbg
 
Upvote 0
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("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
    
    ' 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
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
AlphaFrog said:
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("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
    
    ' 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
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub
Click to expand...

Hi,

I have to thank you for this... it is simply brilliant.

I was wondering, would it be possible to have it copy only a certain amount of the unique values?
I mean, at the moment this code creates a new workbook with a sheet for every unique value on column A; but would it be possible to do it just for the first (lets say) 5 unique values?

thanks a lot
 
Upvote 0
...would it be possible to do it just for the first (lets say) 5 unique values?
Click to expand...

Add the line in red after the counter line.

Code: 
    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        [COLOR="Red"]If counter > 5 Then Exit For[/COLOR]
 
Upvote 0
AlphaFrog said:
Add the line in red after the counter line.

Code: 
    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        [COLOR="Red"]If counter > 5 Then Exit For[/COLOR]
Click to expand...

AWESOME :D

thank you so much for this :) just one more thing for it to be perfect; would it be possible to have the "number 5" defined in a cell?
for instance If counter > ("G1") Then Exit For
(Forgive my very poor knowledge on vba code)
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Link data in sheet to individual - VBA
Replies
9
Views
320
helplessnoobatexcel
H
K
  • Question
vba multiple filter
Replies
8
Views
465
kevin9999
K
duteberta
  • Question
Table filter search box VBA not working...
2
Replies
12
Views
215
Akuini
Akuini
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
225
Coco1
C
S
  • Question
Text file creation macro
Replies
5
Views
270
rlv01
R

Forum statistics

Threads
1,215,108
Messages
6,123,128
Members
449,097
Latest member
mlckr

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top