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

Question

我正在尝试做听起来非常简单的事情，但我不知道如何将其适合现有的VBA代码。 下面的代码一次循环浏览数据透视表1项，然后将数据透视表数据复制到新的工作簿中，并通过电子邮件发送给工作人员

我需要添加的全部内容是将与透视表相同的一张纸上的E15：S16范围内的13x2表复制（调整值和格式）到我称为“每月预测”的标签中的新工作簿中。 与循环等，我不确定如何将其获取到代码中，因此它将复制数据透视图数据，然后将每月预测复制到单独的标签中

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

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的.copy和.PasteSpecial更快VBA。

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

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

'Copy values
  Set rStartCell = ActiveSheet.Range("A1") 'Specify the top-left corner cell of the data you wish to copy
  Set rTable_1 = ActiveSheet.Range(rStartCell, ActiveSheet.Range("Z" & rStartCell.End(xlDown).Row)) 'Change the Z column to the last column of the data you wish to copy. You can automate this by using something like Range(A1).end(xltoright).columns.count formula to grab the number of columns.
  Debug.Print "rTable_1: " & rTable_1.Address & " -> " & rTable_1.Rows.Count & " x " & rTable_1.Columns.Count 'good to test exactly what you're copying

  'Paste Values
  Set rStartCell = Outputs.Range("A1") 'Change A1 to the cell of where you want to paste on the Outputs worksheet in your original workbook.
  Set rTable_2 = Outputs.Range(rStartCell, rStartCell.Offset(rTable_1.Rows.Count - 1, rTable_1.Columns.Count - 1))
  Debug.Print "rTable_2: " & rTable_2.Address & " -> " & rTable_2.Rows.Count & " x " & rTable_2.Columns.Count
  rTable_2.Value = rTable_1.Value
  rTable_1.Copy
  rTable_2.PasteSpecial Paste:=xlPasteFormats 'to copy/paste those formats you need

  'Copy Worksheet and open it in a new workbook
  ThisWorkbook.Sheets("NAME OF OUTPUTS SHEET").Copy 'Using ThisWorkbook to point to the workbook holding this code.
  ActiveSheet.Name = "FCW"

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