0

i have created a Excel VBA Macro and a form which filters on a particular column and exported filtering that particular column to PDF.

Form looks like below image:

enter image description here

below is the code:

Private Sub ExportBtn_Click()


On Error GoTo errHandler



'remove previous autofilter

If ActiveSheet.AutoFilterMode Then
Cells.AutoFilter
End If

Dim strPath As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show = 0 Then
        Exit Sub
    Else
        sItem = .SelectedItems(1)
        GoTo NextCode
    End If

End With
NextCode:
    strPath = sItem
    Set fldr = Nothing



Dim X
Dim objDict As Object
Dim lngRow As Long
Dim Temp As String
Dim wsA As Worksheet
Dim wbA As Workbook
Dim HeaderRange As Range
Set HeaderRange = Range(Cells(1, 1), Cells(1, 1).End(xlToRight))
Dim FilterRange As Range
For Each Cell In HeaderRange
    If Cell.Value Like "*" & ColumnListCombo.Value & "*" Then
    Cell.Select
    End If
Next

MyRow = ActiveCell.Row
MyCol = ActiveCell.Column

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range(Cells(2, MyCol), Cells(Rows.Count, MyCol).End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1

Next

Dim FeederRange As Range
Set FeederRange = Range(Cells(2, MyCol), Cells(Rows.Count, MyCol).End(xlUp))
For Each Key In objDict.keys
    Range("A1").AutoFilter Field:=MyCol, Criteria1:=Key

    Dim strFile As String
    Dim strPathFile As String
    Dim StrLeftHeader As String
    Dim StrMidHeader As String
    Dim StrRightHeader As String
    Dim LeftHeaderCol As Integer
    Dim MidheaderCol As Integer

   ' Get Valuse from ExportForm Comboboxes
    For Each Cell In HeaderRange
    If Cell.Value = LefHeaderCBX.Value Then
        LeftHeaderCol = Cell.Column
    End If
    Next

    For Each Cell In HeaderRange
    If Cell.Value = MiddleheaderCBX.Value Then
        MidheaderCol = Cell.Column
    End If
    Next

    Set wbA = ActiveWorkbook
    Set wsA = ActiveSheet

    'replace spaces and periods in sheet name
     'StrLeftHeader = Range(Cells(2, LeftHeaderCol), Cells(Rows.Count, MyCol).End(xlUp)).offset(0, -1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Value
    If Not LeftHeaderCol = 0 Then
        StrLeftHeader = Range(Cells(2, LeftHeaderCol), Cells(Rows.Count, LeftHeaderCol).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Value
    Else
        StrLeftHeader = ""
    End If
    If Not MidheaderCol = 0 Then
        StrMidHeader = Range(Cells(2, MidheaderCol), Cells(Rows.Count, MyCol).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Value
    Else
        StrMidHeader = ""
    End If

    ' setting Headers and footers
   With wsA.PageSetup
       .LeftHeader = " &B " & LeftheaderPreTBX.Value & " " & StrLeftHeader
       .CenterHeader = " &B " & MidheaderPreTBX.Value & " " & StrMidHeader
       .RightHeader = " &B  " & RightheaderPreTBX.Value & " " & Key

       .LeftFooter = "&B RAPDRP-Change Management"
       .CenterFooter = " &B Advantage One Technologies Consulting Pvt Ltd."

       .RightFooter = " &B Page &P of &N"
     '   'Page &[Page] & of  &[Pages]
    End With

    NameFrstPart = Replace(LeftheaderPreTBX.Value & StrLeftHeader, "/", "-")
    NamescndPart = Replace(MidheaderPreTBX.Value & StrMidHeader, "/", "-")
    strFile = NameFrstPart & NamescndPart & Replace(Key, "/", "-")
    strPathFile = strPath & "/" & strFile

    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=strPathFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

Next

ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False

exitHandler:
    Exit Sub
errHandler:
    Debug.Print "Error number: " & Err.Number _
            & " " & Err.Description
    Resume exitHandler


End Sub

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.