Question

我尝试做一些听起来非常简单的事情，但我无法弄清楚如何将其融入现有的VBA代码中。下面的代码一次循环一个数据透视表1项，并将数据透视表数据复制到新工作簿并通过电子邮件发送给工作人员

我需要添加的是将它复制（只是值和格式化）在与工作表相同的工作表上的E15：S16范围内的13x2表格到我在标签中的新工作簿中命名为＆＃34;每月预测＆＃34;。使用循环等我不知道如何将其转换为代码，因此它将透视数据和月度预测复制到单独的选项卡

希望有道理，任何帮助都会很棒:)

Option Explicit

Sub PivotSurvItems()
Dim i As Integer
Dim sItem As String
Dim sName As String
Dim sEmail  As String
Dim OutApp As Object
Dim OutMail As Object

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

With ActiveSheet.PivotTables("PivotTable1")
    .PivotCache.MissingItemsLimit = xlMissingItemsNone
    With .PivotFields("Staff")
        '---hide all items except item 1
        .PivotItems(1).Visible = True
        For i = 2 To .PivotItems.Count
            .PivotItems(i).Visible = False
        Next
        For i = 1 To .PivotItems.Count
            .PivotItems(i).Visible = True
            If i <> 1 Then .PivotItems(i - 1).Visible = False
            sItem = .PivotItems(i)
            ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True
            Selection.Copy
            Workbooks.Add

            With ActiveWorkbook

                .Sheets(1).Cells(1).PasteSpecial _
                Paste:=xlPasteValuesAndNumberFormats
                Worksheets("Sheet1").Columns("A:R").AutoFit
                ActiveSheet.Range("A2").AutoFilter
                sName = Range("C" & 2)
                sEmail = Range("N" & 2)

                Columns(1).EntireColumn.Delete
                Columns(2).EntireColumn.Delete
                Columns(2).EntireColumn.Delete
                Columns(2).EntireColumn.Delete
                Columns(10).EntireColumn.Delete

                ActiveSheet.Name = "FCW"

                Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Monthly Forecast"

                Worksheets("FCW").Activate

            'create folder
                On Error Resume Next
                MkDir "C:\Temp\FCW" & "\" & sName
                On Error GoTo 0


                .SaveAs "C:\Temp\FCW" & "\" & sName & "\" & sItem & " " & Format(Now(), "DD-MM-YYYY") & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook

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

                        On Error Resume Next
                        With OutMail
                            .To = sEmail
                            .CC = ""
                            .BCC = ""
                            .Subject = "Planning Spreadsheet"
                            .Attachments.Add ActiveWorkbook.FullName
                            .Send
                        End With
                        On Error GoTo 0

                        Set OutMail = Nothing
                        Set OutApp = Nothing



                .Close
            End With


        Next i
    End With
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

Answer 1

不是更改透视表中所有项目的可见性和循环，而是将值分配给“表格”（范围）并将其传递到您希望的位置（它比使用Excel {{1}快得多和VBA中的.copy。

另外，我建议您将所有数据复制到同一工作簿中的“输出”工作表。复制完所有数据后，将该特定输出工作表导出到新工作簿中。这样就可以避免在两个容易出错的工作簿之间复制和粘贴数据。

在你的代码中，我会删除项目循环中的所有内容，直到创建Temp文件夹，并将其替换为以下内容：

.PasteSpecial

您也可以使用此方法复制/粘贴其他提到的表格。

VBA - 将信息复制到新工作簿

1 个答案: