Creating multiple files from an excel filter

R

robmaag

New Member
Joined
Aug 21, 2015
Messages
38
b. Take a spreadsheet that has in Column D a name for an entity: (for example, call it 'United Airlines')

b. Filter the data in spreadsheet by Column D (called United Airlines). Note there will be 56 of these queries...one after the other with diffrent names...

c. Delete all other data in Column D that is not United Airlines

d. Save the results into an excel file

e. Place the file in its own folder


Any thoughts?

Thanks
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
John, Please help.

I need to rename the name 'Cell' and strip out all the wildcard characters...Please help

ub Test_RJM()
Dim DataRange As Range
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long

Application.ScreenUpdating = False
With Worksheets("0100_Member_Tracker")
ActiveSheet.AutoFilterMode = False
With .UsedRange
LastRow = .Rows.Count + .Rows(1).Row - 1
LastColumn = .Columns.Count + .Columns(1).Column - 1
End With
Set DataRange = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
DataRange.Columns(4).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", CopyToRange:=.Cells(1, LastColumn + 2), unique:=True
Set UniqueRng = .Range(.Cells(2, LastColumn + 2), .Cells(.Rows.Count, LastColumn + 2).End(xlUp))
For Each Cell In UniqueRng
DataRange.AutoFilter Field:=4, Criteria1:=Cell
DataRange.Copy
Worksheets.Add
ActiveSheet.Name = Cell


Range("A1").PasteSpecial
Range("A1").Select
Next Cell
.AutoFilterMode = False
.Cells(1, LastColumn + 2).EntireColumn.Delete
.Activate
End With

Application.CutCopyMode = False

Application.ScreenUpdating = True
ActiveSheet.AutoFilterMode = False
End Sub
Private Function sCleanFileName(sText As String) As String
'--replaces any characters in input string that are not allowed
' in filenames
Dim lIdx As Long
Dim vNotAllowed As Variant

vNotAllowed = Split("<,>,?,[,],:,"",*,/,\", ",")
For lIdx = LBound(vNotAllowed) To UBound(vNotAllowed)
sText = Replace(sText, vNotAllowed(lIdx), "_")
Next lIdx
sCleanFileName = sText
End Function
 
Last edited:
Upvote 0
Try this. You need to change the mainFolder string and the "A1:Z" which defines the columns which are filtered.

Code: 
Public Sub Filter_Rows_To_New_Workbooks()

    Dim newWb As Workbook
    Dim dataSheet As Worksheet
    Dim criteriaSheet As Worksheet
    Dim filteredSheet As Worksheet
    Dim criteriaCell As Range
    Dim lr As Long
    Dim mainFolder As String, saveName As String
    
    'Main folder in which results of each filtered name will be saved in a subfolder, named after the column D value
    'with invalid characters removed.  The subfolder is created if it doesn't exist
    
    mainFolder = "C:\Path\To\Folder\"
    If Right(mainFolder, 1) <> "\" Then mainFolder = mainFolder & "\"
    
    'Sheet containing the data to be filtered
    
    Set dataSheet = ThisWorkbook.Worksheets("0100_Member_Tracker")
    
    'Create a temporary sheet to hold the filter criteria
    
    Set criteriaSheet = ThisWorkbook.Worksheets.Add
    
    lr = dataSheet.Range("D" & Rows.Count).End(xlUp).Row
    
    'Put column D unique values in the temporary sheet
    
    dataSheet.Range("D1:D" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=criteriaSheet.Range("A1"), Unique:=True
    
    'Create a temporary sheet to hold each set of filtered data
    
    Set filteredSheet = Worksheets.Add
    
    Application.DisplayAlerts = False
   
    Set criteriaCell = criteriaSheet.Range("A2")
    While criteriaCell.Value <> ""
        filteredSheet.Cells.Clear
        dataSheet.Range("A1:Z" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaCell.Offset(-1).Resize(2), CopyToRange:=filteredSheet.Range("A1"), Unique:=True
        filteredSheet.Name = criteriaCell.Value
        filteredSheet.Copy
        Set newWb = ActiveWorkbook
        saveName = sCleanFileName(criteriaCell.Value)
        If Dir(mainFolder & saveName, vbDirectory) = "" Then MkDir mainFolder & saveName
        newWb.SaveAs mainFolder & saveName & "\" & saveName
        newWb.Close SaveChanges:=True
        criteriaCell.EntireRow.Delete
        Set criteriaCell = criteriaSheet.Range("A2")
    Wend
    
    'Delete the temporary sheets
    
    filteredSheet.Delete
    criteriaSheet.Delete
    
    Application.DisplayAlerts = True
    
End Sub


Private Function sCleanFileName(sText As String) As String
    '--replaces any characters in input string that are not allowed
    ' in filenames
    Dim lIdx As Long
    Dim vNotAllowed As Variant
    
    vNotAllowed = Split("<,>,?,[,],:,"",*,/,\", ",")
    For lIdx = LBound(vNotAllowed) To UBound(vNotAllowed)
        sText = Replace(sText, vNotAllowed(lIdx), "_")
    Next lIdx
    sCleanFileName = sText
End Function

PS please use CODE tags by clicking the # icon in the message editor.
 
Last edited:
Upvote 0
John,

Thank you very much!!! This almost works!!!

The only problem I am having is this error:

Run Time Error 1004:

You typed an invalid name for a sheet or chart: Make Sure that:

The name you typed does not exceed 31 characters
The name does not contain any of the following characters : \ / ? * [ or ]
You did not leave the name blank

Here is where the code is hanging:

filteredSheet.Name = criteriaCell.Value

This is the value where it is hanging: CALIFORNIA PCP ON PPO/PFFS

---

Question: How do I correct this considering I have the Private Function sCleanFileName?

Your thoughs



Dim newWb As Workbook
Dim dataSheet As Worksheet
Dim criteriaSheet As Worksheet
Dim filteredSheet As Worksheet
Dim criteriaCell As Range
Dim lr As Long
Dim mainFolder As String, saveName As String

'Main folder in which results of each filtered name will be saved in a subfolder, named after the column D value
'with invalid characters removed. The subfolder is created if it doesn't exist

mainFolder = "C:\Path\To\Folder\"
If Right(mainFolder, 1) <> "\" Then mainFolder = mainFolder & "\"

'Sheet containing the data to be filtered

Set dataSheet = ThisWorkbook.Worksheets("0100_Member_Tracker")

'Create a temporary sheet to hold the filter criteria

Set criteriaSheet = ThisWorkbook.Worksheets.Add

lr = dataSheet.Range("D" & Rows.Count).End(xlUp).Row

'Put column D unique values in the temporary sheet

dataSheet.Range("D1:D" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=criteriaSheet.Range("A1"), Unique:=True

'Create a temporary sheet to hold each set of filtered data

Set filteredSheet = Worksheets.Add

Application.DisplayAlerts = False

Set criteriaCell = criteriaSheet.Range("A2")
While criteriaCell.Value <> ""
filteredSheet.Cells.Clear
dataSheet.Range("A1:Z" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaCell.Offset(-1).Resize(2), CopyToRange:=filteredSheet.Range("A1"), Unique:=True
filteredSheet.Name = criteriaCell.Value
filteredSheet.Copy
Set newWb = ActiveWorkbook
saveName = sCleanFileName(criteriaCell.Value)
If Dir(mainFolder & saveName, vbDirectory) = "" Then MkDir mainFolder & saveName
newWb.SaveAs mainFolder & saveName & "\" & saveName
newWb.Close SaveChanges:=True
criteriaCell.EntireRow.Delete
Set criteriaCell = criteriaSheet.Range("A2")
Wend

'Delete the temporary sheets

filteredSheet.Delete
criteriaSheet.Delete

Application.DisplayAlerts = True

End Sub


Private Function sCleanFileName(sText As String) As String
'--replaces any characters in input string that are not allowed
' in filenames
Dim lIdx As Long
Dim vNotAllowed As Variant

vNotAllowed = Split("<,>,?,[,],:,"",*,/,\", ",")
For lIdx = LBound(vNotAllowed) To UBound(vNotAllowed)
sText = Replace(sText, vNotAllowed(lIdx), "_")
Next lIdx
sCleanFileName = sText
End Function
 
Upvote 0
John,

Thank you very much!!! This almost works!!!

The only problem I am having is this error:

Run Time Error 1004:

You typed an invalid name for a sheet or chart: Make Sure that:

The name you typed does not exceed 31 characters
The name does not contain any of the following characters : \ / ? * [ or ]
You did not leave the name blank

Here is where the code is hanging:

filteredSheet.Name = criteriaCell.Value

This is the value where it is hanging: CALIFORNIA PCP ON PPO/PFFS

---

Question: How do I correct this considering I have the Private Function sCleanFileName?

Your thoughs
 
Upvote 0
Try...

Code: 
filteredSheet.Name = sCleanFileName(criteriaCell.Value)

Hope this helps!
 
Upvote 0
Hi, This is so close ---

Run Time Error 1004:

You typed an invalid name for a sheet or chart: Make Sure that:

The name you typed does not exceed 31 characters
The name does not contain any of the following characters : \ / ? * [ or ]
You did not leave the name blank

Here is where the code is hanging:

filteredSheet.Name = criteriaCell.Value


I believe now it is hanging on this value (greater than 31 characters...how do we shorten this length for the new file

Run Time Error 1004:

You typed an invalid name for a sheet or chart: Make Sure that:

The name you typed does not exceed 31 characters
The name does not contain any of the following characters : \ / ? * [ or ]
You did not leave the name blank

filteredSheet.Name = criteriaCell.Value

Here is where the code is hanging:

DIGNITY HEALTH - MERCY MEDICAL GROUP
 
Upvote 0
One way would be to make sure that the name doesn't exceed 31 characters...

Code: 
newWb.SaveAs mainFolder & saveName & "\" & [COLOR=#ff0000]Left(saveName, 31)[/COLOR]

Is this acceptable?
 
Upvote 0
Dominic,

Almost :)

I used this and I got the following response:

Run Time Error 1004:

You typed an invalid name for a sheet or chart: Make Sure that:

The name you typed does not exceed 31 characters
The name does not contain any of the following characters : \ / ? * [ or ]
You did not leave the name blank

filteredSheet.Name = criteriaCell.Value

Here is where the code is hanging:

'C\Reports\ McKesson_Valley Care Select\ A513D430'

I don't know why it is hanging up on this 'A513D430'?

It just gave me a run time error 1004...
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
VSTACK data from multiple sheets and filter results for specific dates
Replies
2
Views
152
newxl
N
N
  • Solved
Pasting Value with VBA - Sorta Looping based on a multiple of 30
Replies
2
Views
132
nmbc99
N
N
  • Question
macro to filter spreadsheet by customer code, send relevant data via email
Replies
2
Views
232
Peter_SSs
Peter_SSs
W
  • Question
Combine multiple CSV files with a single sheet each into one workbook with several sheets grouped by categories
Replies
0
Views
428
waptrick
W
G
  • Question
Macro to consolidate multiple worksheets into Master based on cell data?
Replies
1
Views
299
bobaol
B

Forum statistics

Threads
1,215,453
Messages
6,124,918
Members
449,195
Latest member
Stevenciu

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