Need Filter+Export to PDF+Delete Filtered Items Macro

Friends,

Here is a screen shot of my workbook.

Pic.png

I need to create a "Closeout Job" function and I don't know how to go about it. This work book has a ton of entries so I need to start weeding it out. I don't need this list to contain completed jobs but I do need a record of them. I would like to be able to use the filter funtion to select a particular job... Export those entries to a PDF to keep for records and then delete all of those specific entries from the master list.

Here is my filter code and screen shot post filter.

pic2.png

Option Explicit

Dim rngData As Range

Private Sub AnsweredAdd_Click()
AddFilter "AnsweredCombo", "AnsweredList"
End Sub

Private Sub AnsweredDelete_Click()
RemoveFilter "AnsweredList"
End Sub

Private Sub AssignedAdd_Click()
AddFilter "AssignedCombo", "AssignedList"
End Sub

Private Sub AssignedDelete_Click()
RemoveFilter "AssignedList"
End Sub

Private Sub BICAdd_Click()
AddFilter "BICCombo", "BICList"
End Sub

Private Sub BICDelete_Click()
  RemoveFilter "BICList"
End Sub


Private Sub CommandButton1_Click()
ApplyFilter True
End Sub

Private Sub ContractorAdd_Click()
AddFilter "ContractorCombo", "ContractorList"
End Sub

Private Sub ContractorDelete_Click()
RemoveFilter "ContractorList"
End Sub

Private Sub CSJAdd_Click()
AddFilter "CSJCombo", "CSJList"
End Sub

Private Sub CSJDelete_Click()
RemoveFilter "CSJList"
End Sub

Private Sub HighwayAdd_Click()
AddFilter "HighwayCombo", "HighwayList"
End Sub

Private Sub HighwayDelete_Click()
RemoveFilter "HighwayList"
End Sub
Private Sub ProjectAdd_Click()
AddFilter "ProjectCombo", "ProjectList"
End Sub

Private Sub ProjectDelete_Click()
RemoveFilter "ProjectList"
End Sub


Private Sub UserForm_Initialize()
    With ActiveWorkbook.ActiveSheet
        Set rngData = .Range("A5", .Cells(Rows.Count, "M").End(xlUp))
        ApplyFilter
    End With
End Sub

Private Function ApplyFilter(Optional ByVal bKeepFilter As Boolean = False)
    
    Dim ctrl As Control
    Dim wsList As Worksheet
    Dim VisCell As Range
    Dim colList As Object
    Dim arrList() As Variant
    Dim arrFilterData() As Variant
    Dim i As Long, j As Long
    Dim strCBO As String
    
    Set wsList = Sheets("Lists")
    Application.ScreenUpdating = False
    
    For Each ctrl In Me.Controls
        If TypeName(ctrl) = "ListBox" Then
            If ctrl.ListCount > 0 Then
                ReDim arrFilterData(1 To ctrl.ListCount)
                For i = 1 To ctrl.ListCount
                    arrFilterData(i) = ctrl.List(i - 1)
                Next i
                rngData.AutoFilter ctrl.Tag, arrFilterData, xlFilterValues
                Erase arrFilterData
            End If
        End If
    Next ctrl
    
    If bKeepFilter = False Then
        On Error Resume Next
        For i = 1 To 7
            strCBO = Choose(i, "CSJCombo", "ProjectCombo", "HighwayCombo", "ContractorCombo", "BICCombo", "AssignedCombo", "AnsweredCombo")
            Set colList = New Collection
            For Each VisCell In rngData.Offset(, Me.Controls(strCBO).Tag - 1).Resize(, 1).SpecialCells(xlCellTypeVisible).Cells
                If VisCell.Row > 5 Then
                    colList.Add VisCell.Text, VisCell.Text
                End If
            Next VisCell
            With Me.Controls(strCBO)
                .Clear
                If colList.Count > 0 Then
                    ReDim arrList(1 To colList.Count)
                    For j = 1 To colList.Count
                        arrList(j) = colList(j)
                    Next j
                    With wsList.Range("A1").Resize(UBound(arrList))
                        .Value = Application.Transpose(arrList)
                        .Sort .Cells, xlAscending, Header:=xlNo
                        arrList = Application.Transpose(.Value)
                        .ClearContents
                    End With
                    .List = arrList
                    Erase arrList
                End If
            End With
            Set colList = Nothing
        Next i
        On Error GoTo 0
        
        rngData.AutoFilter
        Set wsList = Nothing
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = True
        Unload Me
    End If
    
End Function

Private Function AddFilter(ByVal strCBO As String, ByVal strList As String)
    
    With Me.Controls(strCBO)
        If .ListIndex > -1 Then
            Me.Controls(strList).AddItem .List(.ListIndex)
            ApplyFilter
        End If
    End With
    
End Function

Private Function RemoveFilter(ByVal strList As String, Optional ByVal bClearAll As Boolean = False)
    
    Dim i As Long
    
    With Me.Controls(strList)
        If bClearAll = False Then
            If .ListIndex > -1 Then
                .RemoveItem .ListIndex
                ApplyFilter
            End If
        Else
            For i = .ListCount - 1 To 0 Step -1
                .RemoveItem i
            Next i
            ApplyFilter
        End If
    End With
    
End Function

How would I go about doing something like that?

Thanks in advance,

Mike

Wow homerun again...

But I have a few questions if you don't mind. Using a modified version of the code that you gave me the other day I created this userform that populates correctly...

Job Close Out.png

I would like to use this form so that when OKButton is clicked, it does the filter, creates the PDF (and names it by the job number like ###-##-####.pdf) and then deletes those entries all at the click of that button.

And then also, is it possible to have that pdf include the cell comments? the information in the comments is important to include for records.

Then a quick aside...
I am new to vba and this forum and forums in general. Why are you so helpful? Are forum contributers compensated for all the help they provide or is it all done out of a generous spirit?

Thanks again for everything; all the help you have offered is really impressing my boss

-Mike

Yes, the drop down is just populated by CSJ #'s. so upon selecting one and clicking OK, I would want a macro that filters out everything except entries with that CSJ, exports to PDF with comments somehow, and deletes those entries from the master list... All at the click of the OKButton with ScreeUpdating = False.

Is that possible?

Thanks,

---------- Post added at 01:31 PM ---------- Previous post was at 01:30 PM ----------

And Yes, The CSJ that is selected from the combobox would be the file name of the PDF

Well I'm trying to follow the methodology here and I don't understand why you set strCSJ = 1 / 0
I assume that wasn't a typo and you are forcing an error which is sending compiler to

If Err Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

and then ok on err just exits the sub

OK tigeravatar,

I have been messing with the code that you gave me to try and get it to format the PDF just right. I have it to where it works now and does everything that it is supposed to but the coding is so clunky and slow. After I click OK it literally takes a good 2 minutes for the PDF to generate. Would you mind looking through the code and streamlining it a bit so that it runs more efficiently? I have tried to add as many comments as possible to help you follow my thought process.

I will also attach a sample PDF that is generated so that it will make more sense why I added the row and column labels

0718 - 01 - 052 - 02-Aug-12 11_23_24.pdf

Private Sub OKButton_Click()
Application.ScreenUpdating = False
    Dim rngData As Range
    Dim CommentCell As Range
    Dim lCalc As XlCalculation
    Dim strCSJ As String
    Dim NumRows As Integer
    Dim i As Integer
    Dim NumCols As Integer
    
    
    'For some reason not doing this messes up the copy paste to a new sheet later on...
    ActiveSheet.Cells.EntireColumn.Hidden = False

    If Me.CSJCombo.ListIndex = -1 Then
        Me.CSJCombo.SetFocus
        MsgBox "Must select a job.", , "Missing Job"
        Exit Sub
    End If
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    On Error GoTo CleanExit
    
    strCSJ = Me.CSJCombo.Text
    Range("A5", Cells(Rows.Count, "A").End(xlUp)).Resize(, 15).Select
    Set rngData = Selection
    rngData.AutoFilter 1, strCSJ
    
    With Sheets.Add
        rngData.Resize(1).Copy .Range("B2")
        rngData.Offset(1).Copy .Range("B3")
        Cells.Select
        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Landscape Orientation and Narrow Margins'''''''''''''''
'This is where i need to set the page to landscape orientation and narrow margins so that is prints the PDF correctly but I just used
'The record macro function and to do those simple things, the code was forever long. I have omitted it here so that this post is not too long
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'This creates the same column widths as the main master sheet
        Columns("A").ColumnWidth = 3.29
        Columns("B").ColumnWidth = 10.71
        Columns("C").ColumnWidth = 12.14
        Columns("D").ColumnWidth = 7
        Columns("E").ColumnWidth = 14.29
        Columns("F").ColumnWidth = 3.43
        Columns("G").ColumnWidth = 22
        Columns("H").ColumnWidth = 2.71
        Columns("I").ColumnWidth = 5.43
        Columns("J").ColumnWidth = 8.57
        Columns("K").ColumnWidth = 8.57
        Columns("L").ColumnWidth = 11
        Columns("M").ColumnWidth = 8.43
        Columns("N").ColumnWidth = 8.14
        Cells.EntireRow.AutoFit
        
        'Add title to new wksht
        Range("A1").Resize(, 16).Select
        Selection.Merge
        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
        End With
        ActiveCell.Value = strCSJ
        Range("B3:P3").Activate
        Range(Selection, Selection.End(xlDown)).Select
        NumRows = Selection.Rows.Count
        'Delete all previous conditional formatting and add in alternating row shading
        With Selection
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
        .FormatConditions(1).Interior.Pattern = xlSolid
        .FormatConditions(1).Interior.PatternColorIndex = xlAutomatic
        .FormatConditions(1).Interior.Color = 15921906
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        End With
        Columns("O").EntireColumn.Delete
        Columns("L").EntireColumn.Delete
        Range("A3").Select
        'Adding row labels
        For i = 4 To NumRows + 3
            ActiveCell.Offset(i - 4, 0).Value = i
        Next i
        'Adding Column labels
        Rows("2:2").Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        NumCols = Range("B2").Offset(1, 0).Columns.Count
        Range("B2").Select
        For i = 65 To 90
        If ActiveCell.Offset(1, i - 65).Value <> "" Then
         ActiveCell.Offset(0, i - 65).Value = Chr$(i)
         Else
         End If
         Next i
         '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Adding All Borders to row and column labels''''''
         Range(Selection, Selection.End(xlToRight)).Select
             Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    ActiveCell.Offset(2, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        

        On Error GoTo CleanExit
        .ExportAsFixedFormat xlTypePDF, "T:\DEN\RFI Records\" & strCSJ & " - " & Format(Now, "dd-mmm-yy hh_mm_ss") & ".pdf"
        .Delete
    End With
         

    
    rngData.Offset(1).EntireRow.Delete
    rngData.AutoFilter
    'Rehide columns from beginning
    Columns("N:O").EntireColumn.Hidden = True
    
CleanExit:
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    If Err Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    rngData.Parent.AutoFilterMode = False
    Set rngData = Nothing
    Unload Me
Application.ScreenUpdating = True
End Sub

Awesome. Those adjustments sped it up a bit, but now I have another problem. In the PDF that I sent you, it had a cell reference and all of the comments at the end of the PDF. Now for some reason it will not include the comments anymore. I have added this and it still won't work...

    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .Orientation = xlLandscape
        .PrintComments = xlPrintSheetEnd    End With

whelp... you were right as always... I feel bad because I can't give you any reputation because you are the only one who ever answers my questions!

Take care. Unitl next time.

-Mike