![Excel 崩溃,宏有时有效,有时无效](https://linux22.com/image/1537096/Excel%20%E5%B4%A9%E6%BA%83%EF%BC%8C%E5%AE%8F%E6%9C%89%E6%97%B6%E6%9C%89%E6%95%88%EF%BC%8C%E6%9C%89%E6%97%B6%E6%97%A0%E6%95%88.png)
我创建了一个 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