Consulting

Results 1 to 1 of 1

Thread: Print sheets based on filtered results from multiple workbooks

  1. #1
    VBAX Newbie
    Joined
    Aug 2011
    Posts
    1
    Location

    Print sheets based on filtered results from multiple workbooks

    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

    [vba]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[/vba]
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •