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
어디에서 충돌합니까? 오류 메시지는 무엇입니까?
—
DavidPostill
오류 메시지 없음 "Excel이 작동을 멈췄습니다"라는 메시지가 표시되고 모든 것이 사라졌습니다. 일부는 완전히 작동하고 일부는 시간이 지남에 따라 작동하지 않습니다.
—
Akhil Kumar