ผมได้เรียง Code ใหม่ครับขั้นตอนก็ดังนี้เลย
1.เลือกสาขา ที่กำหนด ออกรายงาน(ยังหาวิธีไม่เจอครับ)
2.แปรรูป Clear Filters กำหนดสีตาราง
3.resize Table แล้วปรับตาราง ปรับการ Print ให้ตรงกับ Offset
4.เก็บค่าตัวแปร เพื่อเตรียมตั้งชื่อ PDF
5.ออก PDF
5.สำรวจเงื่อนไข Next จากการกำหนดสาขา
6.จบการทำงาน
Module 5
Code: Select all
Sub Button99_PDF()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler
Dim tblRaw As ListObject, tblFiltered As ListObject
Dim sh_raw As Worksheet, sh_filtered As Worksheet
Dim critRange As Range, copyToRng As Range, resizeRng As Range
Dim startRow As Long, lastRow As Long
Dim slItem As SlicerItem
Dim i As Long
10 Application.ScreenUpdating = False
20 Application.EnableEvents = False
30 Application.Calculation = xlCalculationManual
If Sheets("Pivot_Filters").Range("a8").Value = "" Then Exit Sub
Set wsPF = ThisWorkbook.Sheets("Pivot_Filters")
Set wsSD = ThisWorkbook.Sheets("SalesData")
Set wsOP = ThisWorkbook.Sheets("Output")
Set tblFiltered = wsOP.ListObjects("table2")
Set ws = ThisWorkbook.Sheets("Output")
With ActiveWorkbook.SlicerCaches("Slicer_รหัส_สาขา")
'--deselect all items except the first
.SlicerItems(1).Selected = True
For Each slItem In .VisibleSlicerItems
If slItem.Name <> .SlicerItems(1).Name Then _
slItem.Selected = False
Next slItem
'--step through each item and run custom function
For i = 2 To .SlicerItems.Count
.SlicerItems(i).Selected = True
.SlicerItems(i - 1).Selected = False
Application.ScreenUpdating = True
90 Select Case tblFiltered.ListRows.Count
Case Is > 0
100 tblFiltered.DataBodyRange.Delete
110 tblFiltered.ListRows.Add
120 Case Else
130 tblFiltered.ListRows.Add
140 End Select
With ActiveWorkbook.SlicerCaches("Slicer_ประเภท_ใบอนุญาต")
.SlicerItems("ตัวแทน").Selected = True
.SlicerItems("Micro Insurance").Selected = True
.SlicerItems("นายหน้าบุคคล").Selected = False
.SlicerItems("นายหน้านิติบุคคล").Selected = False
.SlicerItems("พรบ.").Selected = True
.SlicerItems("นายหน้า").Selected = False
.SlicerItems("โบรคเกอร์").Selected = False
.SlicerItems("ไม่มีบัตร").Selected = False
.SlicerItems("FALSE").Selected = False
End With
With ActiveWorkbook.SlicerCaches("Slicer_ชื่อหลักสูตร")
.SlicerItems("ขอต่อใบอนุญาตนายหน้าประกันวินาศภัยครั้งที่ 1").Selected = True
.SlicerItems("ขอต่อใบอนุญาตนายหน้าประกันวินาศภัยครั้งที่ 2").Selected = True
.SlicerItems("ขอต่อใบอนุญาตนายหน้าประกันวินาศภัยครั้งที่ 3").Selected = True
.SlicerItems("ขอต่อใบอนุญาตนายหน้าประกันวินาศภัยครั้งที่ 4").Selected = True
.SlicerItems("ขอรับใบอนุญาตนายหน้าประกันวินาศภัย").Selected = True
.SlicerItems("ขอต่อใบอนุญาตตัวแทนประกันวินาศภัยครั้งที่ 1").Selected = True
.SlicerItems("ขอต่อใบอนุญาตตัวแทนประกันวินาศภัยครั้งที่ 2").Selected = True
.SlicerItems("ขอต่อใบอนุญาตตัวแทนประกันวินาศภัยครั้งที่ 3").Selected = True
.SlicerItems("ขอต่อใบอนุญาตตัวแทนประกันวินาศภัยครั้งที่ 4").Selected = True
.SlicerItems("ขอรับใบอนุญาตตัวแทนประกันวินาศภัย").Selected = True
.SlicerItems("ไม่มีข้อมูล").Selected = False
End With
ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleLight21"
wsSD.Range("Sales_Data[#All]").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=wsPF.Range("CritSlicers"), _
CopyToRange:=wsOP.Range("ExtractSlicers"), _
Unique:=False
'Find Filtered table Header row
180 startRow = tblFiltered.HeaderRowRange.Row
'Find last row on Filtered tab (deduct 1 since Advanced filter retrieves the headers)
190 lastRow = wsOP.Columns(2).Find("*", , , , xlByRows, xlPrevious).Row
'If the last raw is greater than the Header row, resize the Filtered table and delete the retrieved Headers (which will be in the first row of the Filtered table)
200 If lastRow > startRow Then
210 Set resizeRng = Range("table2[#All]").Resize(tblFiltered.Range.Rows.Count + (lastRow - startRow - 1), tblFiltered.Range.Columns.Count)
220 tblFiltered.Resize resizeRng
'230 tblFiltered.ListRows(2).Delete
240 Else
'If the last row is equal to Header row it means only the Column headers have been fetched, so there is no matching row to the filter criterias
'The if condition is only for let's say second line of defence
250 If tblFiltered.HeaderRowRange(11, 2) = tblFiltered.DataBodyRange(11, 2) Then
260 tblFiltered.DataBodyRange.Delete
270 End If
280 End If
290 Application.ScreenUpdating = True
300 Application.EnableEvents = True
310 Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.Worksheets("Output").ListObjects("Table2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Output").ListObjects("Table2").Sort.SortFields.Add2 _
Key:=Range("Table2[ครั้งที่]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Output").ListObjects("Table2").Sort.SortFields.Add2 _
Key:=Range("Table2[วัน" & Chr(10) & "หมดอายุ]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Output").ListObjects("Table2").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("Output").Columns("A:M").AutoFit
Worksheets("Output").Columns("K").Hidden = True
Worksheets("Output").PageSetup.PrintArea = "PrintFocus"
stword3 = GetSelectedSlicerItems("Slicer_รหัส_สาขา")
stword = "รายงานต่อใบอนุญาต"
stword4 = "ประกันวินาศภัย"
stword5 = GetSelectedSlicerItems2("Slicer_ประเภท_ใบอนุญาต")
Range("A9") = stword & " " & stword3 & " " & stword5 & " " & stword4
If InStr(Range("a9").Value, "นายหน้า") > 0 Then
lictype = "นายหน้า"
ElseIf InStr(Range("a9").Value, "ตัวแทน") > 0 Then
lictype = "ตัวแทน"
ElseIf InStr(Range("a9").Value, "ใบอนุญาตทั้งหมด") > 0 Then
lictype = "ร่วมใบอนุญาต"
End If
codebranch = GetSelectedSlicerItems3("Slicer_รหัส_สาขา")
branchname = GetSelectedSlicerItems("Slicer_รหัส_สาขา")
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
filefilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
Next i
End With
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
รายการทดสอบ.xlsm
ติดปัญหา Loop สาขา จนหมด และยังหาวิธีการกำหนด สาขาที่ต้องการไม่ได้ครับ
You do not have the required permissions to view the files attached to this post.
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
