Я создал макрос Excel VBA и форму, которая фильтрует по конкретному столбцу и экспортирует фильтрацию этого конкретного столбца в PDF.

Форма выглядит как на картинке ниже:

ниже код:

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
|источник

0