PDA

View Full Version : Print sheets based on filtered results from multiple workbooks



Lungfish
08-06-2011, 05:54 PM
Hi all first time poster here.
I have a macro that looks through workbooks in a folder and searches column A in sheet 1 for results that meet a criteria. When it finds a result, the macro will copy the entire corresponding row into a new workbook and continue searching for more matching results.
Each workbook in the folder has a main sheet (sheet1) that has 17 rows (jobs). Each row(job) has an associated checklist on another sheet (sheets 2-18).

At the moment I run the filter macro to get the list of "jobs" that meet the filter criteria.
I then manually have to go back through all the workbooks in the folder to print the associated checklists.

Is there a way to add/run a print macro to print the associated checklists as the filter macro finds a result?

I have attached the relevant part of the code (and sample workbook) below.

Any help will be greatly appreciated.
Regards,
Martin

Sub Filter_Job_Checklists()
Dim myFiles As Variant
Dim myCountOfFiles As Long

myCountOfFiles = Get_File_Names( _
MyPath:="C:\MyFilePath\", _
Subfolders:=False, _
ExtStr:="JOB CHECKLIST*.xlsm", _
myReturnedFiles:=myFiles)

If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If

Get_Filter _
FileNameInA:=False, _
SourceShName:="", _
SourceShIndex:=1, _
FilterRng:="A1:W" & Rows.Count, _
FilterField:=1, _
FilterValue1:="<6", _
myReturnedFiles:=myFiles


End Sub

'Macro to find values (FilterValue 1 & 2) in the Job Checklists contained in the folder.

Sub Get_Filter(FileNameInA As Boolean, SourceShName As String, _
SourceShIndex As Integer, FilterRng As String, FilterField As Integer, _
FilterValue1 As String, myReturnedFiles As Variant)
Dim SourceRange As Range, destrange As Range
Dim mybook As Workbook, BaseWks As Worksheet
Dim rnum As Long, CalcMode As Long
Dim SourceSh As Variant
Dim rng As Range
Dim RwCount As Long
Dim I As Long
Dim z As Long
Dim vHdr As Variant
Dim Counter As Integer
Dim lastCell As String
Dim LC As Range
Dim x As Long
Dim lastC As Range
Dim LR As Long
Dim OutApp As Object
Dim OutMail As Object

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Open new workbook and add one sheet named with the current date
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
BaseWks.Name = "1"
'Set start row for the Data
rnum = 1

'Check if we use a named sheet or the Sheet index
If SourceShName = "" Then
SourceSh = SourceShIndex
Else
SourceSh = SourceShName
End If

'Loop through all files in the array of found files(myFiles)
For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myReturnedFiles(I))
On Error GoTo 0

If Not mybook Is Nothing Then

'Set SourceRange and check if it is a valid range
On Error Resume Next

With mybook.Sheets(SourceSh)
Set SourceRange = Application.Intersect(.UsedRange, .Range(FilterRng))
End With

If Err.Number > 0 Then
Err.Clear
Set SourceRange = Nothing
Else
'If SourceRange use all columns then skip this file
If SourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set SourceRange = Nothing
End If
End If
On Error GoTo 0

If Not SourceRange Is Nothing Then

'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1

With SourceRange.Parent
Set rng = Nothing

'Firstly, remove the AutoFilter
.AutoFilterMode = False

'Filter the range on the FilterField column (Weeks to Go)
SourceRange.AutoFilter Field:=FilterField, _
Criteria1:=FilterValue1

With .AutoFilter.Range
'Check if there are results after you use AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1

If RwCount = 0 Then
'There is no data, only the header
Else
'Set a range without the Header row
Set rng = .Resize(.Rows.Count + 1, .Columns.Count). _
Offset(1, 0).SpecialCells(xlCellTypeVisible)

If FileNameInA = True Then
'Copy the range and the file name
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
Else
'Copy the range
If rnum + RwCount < BaseWks.Rows.Count Then
rng.Copy BaseWks.Cells(rnum, "A")
End If
End If
End If
End With

'Remove the AutoFilter
.AutoFilterMode = False

End With
End If

'Close the "JOB CHECKLIST *" without saving
mybook.Close savechanges:=False
End If

'Open the next workbook
Next I