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 in VBA。

此外，我建议您将所有数据复制到“输出”工作表中e相同的工作簿。当所有数据都被复制后，将该特定输出工作表导出到新的工作簿中。这样可以避免在两个不同的工作簿之间复制和粘贴数据，这些工作簿可能容易出错。

在代码中，我会从项目循环，直至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" 

您可以使用此方法复制/粘贴等表也提到了。