Snasui Excel Forum

Code: Select all

For Each slcCache In ActiveWorkbook.SlicerCaches
        slcCache.ClearManualFilter
Next

With ActiveWorkbook.SlicerCaches("Slicer_ชื่อสี")
    For Each oSlicerItem In .SlicerItems
        If oSlicerItem.Name = "น้ำตาล" Then
            oSlicerItem.Selected = True
        Else
            oSlicerItem.Selected = False
        End If
        
    Next oSlicerItem
End With

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

Code: Select all

Sub test()
    Dim s As SlicerCache, arr(), sPd As SlicerCache
    Dim i As Integer, j As Integer, k As Integer, l As Integer
    For Each s In ActiveWorkbook.SlicerCaches
        With s
            If s.Name = "Slicer_ÃËÑÊ_ÊÒ¢Ò" Then
                Set sPd = ActiveWorkbook.SlicerCaches(s.Name)
                For j = 1 To s.SlicerItems.Count
                    If s.SlicerItems(j).Selected = True Then
                        'Debug.Print s.SlicerItems(j).Name
                        ReDim Preserve arr(i)
                        arr(i) = s.SlicerItems(j).Name
                        i = i + 1
                    End If
                Next j
            End If
        End With
    Next s
    For k = 1 To UBound(arr) + 1
        sPd.ClearManualFilter
        For l = 1 To sPd.SlicerItems.Count - 1
            sPd.SlicerItems(l).Selected = False
        Next l
        sPd.SlicerItems(k).Selected = True
        'Your command for printing.
    Next k
End Sub

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 s As SlicerCache, arr(), sPd As SlicerCache
    Dim i As Integer, j As Integer, k As Integer, l As Integer

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")

For Each s In ActiveWorkbook.SlicerCaches
        With s
            If s.Name = "Slicer_รหัส_สาขา" Then
                Set sPd = ActiveWorkbook.SlicerCaches(s.Name)
                For j = 1 To s.SlicerItems.Count
                    If s.SlicerItems(j).Selected = True Then
                        'Debug.Print s.SlicerItems(j).Name
                        ReDim Preserve arr(i)
                        arr(i) = s.SlicerItems(j).Name
                        i = i + 1
                    End If
                Next j
            End If
        End With
    Next s
    For k = 1 To UBound(arr) + 1
        sPd.ClearManualFilter
        For l = 1 To sPd.SlicerItems.Count - 1
            sPd.SlicerItems(l).Selected = False
        Next l
        sPd.SlicerItems(k).Selected = 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 k


exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Code: Select all

    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

Code: Select all

        Next l
        sPd.SlicerItems(k).Selected = True
        "Advanced Filter"
        "คำสั่ง Print PDF"
        

Code: Select all

wsSD.Range("Sales_Data[#All]").AdvancedFilter _
  Action:=xlFilterCopy, _
  CriteriaRange:=wsPF.Range("CritSlicers"), _
  CopyToRange:=wsOP.Range("ExtractSlicers"), _
  Unique:=False

Code: Select all

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