Question

我正在运行以下代码以自动选择数据透视表中的AC编号。这本身就完美无缺

Sub Pivotselection()

    Dim pi As PivotItem

    With ActiveSheet.PivotTables(1).PivotFields("Account Number")

        For Each pi In .PivotItems

            .CurrentPage = pi.Name
            Call Mail_Range
        Next
    End With

End Sub

我遇到的麻烦是，当我尝试调用Mail_Range宏时，它会出现一个Complile Error：Type Mismatch

我已经在Mail_Range宏中声明了Pivotal Item，但它没有任何区别。

Sub Mail_Range()

    Dim Source As Range

    Dim Dest As Workbook
    Dim wb As Workbook
    Dim pi As PivotItem
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Set Source = pi.Name
    On Error Resume Next
    Set Source = pi.Name
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ThisWorkbook.Sheets("Mail").Range("A2").Value
            .CC = ""
            .Subject = "Back Order Update"
            .Body = "Thank you for joining the back order trial we are currently running. at the moment this is only a trial and this wont be reflective of the end product what we are looking to get right is the data(Attached) and how it is presented to you the opticians. please if you could send your review of the attached spreadsheet and any changes you would like to be made to JBradfield@coopervision.co.uk. Thank you for your participation "
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub`

我想知道是否有人可以帮忙解决这个问题。

非常感谢

杰基

Answer 1

更改“结果”表中的数据透视表过滤器。检查此代码，它可能会对您有所帮助

    Public Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim pt As PivotTable
    ' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = Range("E5")
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
 Set pt = Worksheets("Results").PivotTables("PivotTable3")
 pt.PivotFields("User Name").ClearAllFilters
 pt.PivotFields("User Name").CurrentPage = Range("E5").Value
    End If
 End Sub

Sub Mail()
    Dim OutlookApp As Object
    Dim Mess As Object, Recip As String, Subj As String
    Dim pt As Range
    Set pt = Worksheets("Results").Range("K8:T21").SpecialCells(xlCellTypeVisible)

    Recip = [E5].Value & "@Email.com"
    Subj = [G15].Value
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutlookApp = CreateObject("Outlook.Application")
    Set Mess = OutlookApp.CreateItem(0)
    With Mess
        .Subject = Subj
        .HTMLBody = RangetoHTML(pt)
        .Recipients.Add Recip
        .cc = "abc@email.com"
                    ' In place of the following statement, you can use ".send" to
            ' send the e-mail message.
        .display
    End With
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

如何在邮件范围子中引用数据透视表结果

1 个答案: