PDA

View Full Version : Autofiltering data in several sheets and pasting to file with same name as criteria



snowbounduk
08-01-2011, 06:11 AM
I have the following code I use to filter 6 worksheets, with the criteria in A2:A159, and paste that data to sheets with the same name as the criteria.

Each sheet ("Risks", "Issues", "Assumptions", "Dependencies", "Constraints", "Lessons") has the project number in column A.

Where the project number equals that in the criteria (A2:A159), it pastes the data to a sheet with the same name as the criteria.

So I end up with a sheet for each project, which lists all the ("Risks", "Issues", "Assumptions", "Dependencies", "Constraints", "Lessons") .

The code: Sub ACreateProjectRAIDsThisWorks()
myCriteria = Range("A2:A159")
SourceSheetNames = Array("Risks", "Issues", "Assumptions", "Dependencies", "Constraints", "Lessons")
For Each Crit In myCriteria
With Sheets(Crit)

' Delete Old Stuff First
Range(.Range("A1"), .Range("A1").End(xlDown)).EntireRow.Delete
' This will put the relevant line in from the summary tab for this programme
' Summary Line
Range(.Range("A1"), .Range("A1").End(xlDown)).EntireRow.Delete
.Range("A1").Value = "Project"
.Range("A2").Value = "Summary"
For Each SourceShtNme In SourceSheetNames
.Range("A1").End(xlDown).Offset(1).Value = SourceShtNme
Sheets(SourceShtNme).Range("A1").AutoFilter Field:=1, Criteria1:=Crit
Sheets(SourceShtNme).AutoFilter.Range.Copy .Range("A1").End(xlDown).Offset(1)
Sheets(SourceShtNme).Range("A1").AutoFilter Field:=1
Next SourceShtNme
End With
Next Crit
End Sub

Rather than adding the filtered data to a sheet within this worksheet, I would like to create a new file for each of the projects listed (A2:A159), with 6 sheets ("Risks", "Issues", "Assumptions", "Dependencies", "Constraints", "Lessons").

I have found the following code to open the files (I've created a file for each project based on a template and need the data to paste in at cell B12 on each sheet) but am unsure how to insert my macro which would append to the workbooks rather than the worksheets.

Option Explicit
Sub OpenAllFilesInFolderAndPerformAction()
Dim wb As Workbook
Dim TheFile As String
Dim MyPath As String
MyPath = GetFolder
ChDrive Left(MyPath, Application.WorksheetFunction.Search(":", MyPath))
ChDir MyPath
TheFile = Dir("*.xls")
On Error Resume Next
Do While TheFile <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
wb.Activate
'PUT YOUR MACRO HERE
'PUT YOUR MACRO HERE
'PUT YOUR MACRO HERE
'PUT YOUR MACRO HERE
'PUT YOUR MACRO HERE
'PUT YOUR MACRO HERE
wb.Close
Application.ScreenUpdating = True
TheFile = Dir
Loop
Set wb = Nothing
End Sub
Function GetFolder(Optional strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Any help is much appreciated, I am at the limit of my limited knowledge!