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" 

您可以使用此方法複製/粘貼等表也提到了。